snap-0.14.0.6/0000755000000000000000000000000012552604453011075 5ustar0000000000000000snap-0.14.0.6/CHANGELOG.md0000644000000000000000000000032212552604453012703 0ustar0000000000000000# 0.14.0.5 * Eliminate unnecessary dependency on syb # 0.14.0 * Allow lens-4.8 * Remove re-export of Control.Lens.Loupe, since it was removed upstream. * Remove re-exports of other non-snap modules in Snap. snap-0.14.0.6/CONTRIBUTORS0000644000000000000000000000042112552604453012752 0ustar0000000000000000Ozgun Ataman Doug Beardsley Gregory Collins Carl Howells Chris Smith Jurriën Stutterheim Alfredo Di Napoli snap-0.14.0.6/LICENSE0000644000000000000000000000274512552604453012112 0ustar0000000000000000Copyright (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. snap-0.14.0.6/README.md0000644000000000000000000000325212552604453012356 0ustar0000000000000000Snap Framework ============== Snap is a web framework for Haskell, based on iteratee I/O (as [popularized by Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). For more information about Snap, read the `README.SNAP.md` or visit the Snap project website at http://www.snapframework.com/. ## Library contents This is top-level project for the Snap Framework, which contains: * a command-line utility for creating initial Snap applications * a library allowing Snap applications to recompile actions on the fly in development mode, with no performance loss in production mode. * a "snaplet" API allowing web applications to be build from composable pieces. Building snap ============= The snap tool and library are built using [Cabal](http://www.haskell.org/cabal/) and [Hackage](http://hackage.haskell.org/packages/hackage.html). Just run cabal install from the `snap` toplevel directory. ## Building the Haddock Documentation The haddock documentation can be built using 'cabal haddock'. The docs get put in `dist/doc/html/`. ## Building the testsuite 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`. ## Roadmap to Understanding Snaplets 1. Read Tutorial.lhs which is in `project_template/tutorial/src`. 2. Generate and read the haddock docs. 3. The test code has the nice property that it actually functions as a pretty good example app and covers a lot of the use cases. 4. If you're interested in the implementation, read design.md. snap-0.14.0.6/README.SNAP.md0000644000000000000000000000227312552604453013120 0ustar0000000000000000Snap Framework -------------- Snap is a simple and fast web development framework and server written in Haskell. For more information or to download the latest version, you can visit the Snap project website at http://snapframework.com/. Snap Status and Features ------------------------ The Snap core system consists of: * a high-speed HTTP server, with an optional high-concurrency backend using the [libev](http://software.schmorp.de/pkg/libev.html) library * a sensible and clean monad for web programming * an xml-based templating system for generating HTML that allows you to bind Haskell functionality to XML tags without getting PHP-style tag soup all over your pants * a "snaplet" system for building web sites from composable pieces. Snap is currently only officially supported on Unix platforms; it has been tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows. 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-0.14.0.6/Setup.hs0000644000000000000000000000005712552604453012533 0ustar0000000000000000import Distribution.Simple main = defaultMain snap-0.14.0.6/snap.cabal0000644000000000000000000002116512552604453013027 0ustar0000000000000000name: snap version: 0.14.0.6 synopsis: Top-level package for the Snap Web Framework description: This is the top-level package for the official Snap Framework libraries. It includes: . * The Snaplets API . * The \"snap\" executable program for generating starter projects . * Snaplets for sessions, authentication, and templates . To get started, issue the following sequence of commands: . @$ cabal install snap $ mkdir myproject $ cd myproject $ snap init@ . If you have trouble or any questions, see our FAQ page () or the documentation (). license: BSD3 license-file: LICENSE author: Ozgun Ataman, Doug Beardsley, Gregory Collins, Carl Howells, Chris Smith maintainer: snap@snapframework.com build-type: Simple cabal-version: >= 1.8 homepage: http://snapframework.com/ category: Web, Snap extra-source-files: CHANGELOG.md, CONTRIBUTORS, LICENSE, README.md, README.SNAP.md, project_template/barebones/.ghci, project_template/barebones/foo.cabal, project_template/barebones/log/access.log, project_template/barebones/src/Main.hs, project_template/default/.ghci, project_template/default/foo.cabal, project_template/default/log/access.log, project_template/default/log/error.log, project_template/default/static/screen.css, project_template/default/snaplets/heist/templates/base.tpl, project_template/default/snaplets/heist/templates/index.tpl, project_template/default/snaplets/heist/templates/_login.tpl, project_template/default/snaplets/heist/templates/login.tpl, project_template/default/snaplets/heist/templates/_new_user.tpl, project_template/default/snaplets/heist/templates/new_user.tpl, project_template/default/snaplets/heist/templates/userform.tpl, project_template/default/src/Application.hs, project_template/default/src/Main.hs, project_template/default/src/Site.hs, project_template/tutorial/.ghci, project_template/tutorial/foo.cabal, project_template/tutorial/log/placeholder, project_template/tutorial/src/Part2.lhs, project_template/tutorial/src/Tutorial.lhs, extra/hscolour.css, extra/haddock.css, extra/logo.gif, test/snap-testsuite.cabal, test/runTestsAndCoverage.sh, test/suite/TestSuite.hs, test/suite/NestTest.hs, test/suite/Snap/TestCommon.hs, test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs, test/suite/Snap/Snaplet/Internal/RST/Tests.hs, test/suite/Snap/Snaplet/Internal/Tests.hs, test/suite/Snap/Snaplet/Internal/LensT/Tests.hs, test/suite/Blackbox/Types.hs, test/suite/Blackbox/FooSnaplet.hs, test/suite/Blackbox/BarSnaplet.hs, test/suite/Blackbox/Common.hs, test/suite/Blackbox/EmbeddedSnaplet.hs, test/suite/Blackbox/Tests.hs, test/suite/Blackbox/App.hs, test/suite/SafeCWD.hs, test/suite/AppMain.hs, test/non-cabal-appdir/db.cfg, test/non-cabal-appdir/bad.tpl, test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl, test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl, test/non-cabal-appdir/snaplets/baz/devel.cfg, test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl, test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl, test/non-cabal-appdir/snaplets/heist/templates/index.tpl, test/non-cabal-appdir/snaplets/heist/templates/session.tpl, test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl, test/non-cabal-appdir/snaplets/heist/templates/page.tpl, test/non-cabal-appdir/good.tpl, test/non-cabal-appdir/log/placeholder, test/non-cabal-appdir/devel.cfg, test/foosnaplet/templates/foopage.tpl, test/foosnaplet/devel.cfg Flag old-base default: False manual: False Library hs-source-dirs: src exposed-modules: Snap, Snap.Snaplet Snap.Snaplet.Heist Snap.Snaplet.HeistNoClass Snap.Snaplet.Heist.Compiled Snap.Snaplet.Heist.Generic Snap.Snaplet.Heist.Interpreted Snap.Snaplet.Auth Snap.Snaplet.Auth.Backends.JsonFile Snap.Snaplet.Config Snap.Snaplet.Session Snap.Snaplet.Session.Common Snap.Snaplet.Session.SessionManager Snap.Snaplet.Session.Backends.CookieSession Snap.Snaplet.Test other-modules: Control.Access.RoleBased.Checker Control.Access.RoleBased.Role Control.Access.RoleBased.Types Control.Access.RoleBased.Internal.Role Control.Access.RoleBased.Internal.RoleMap Control.Access.RoleBased.Internal.Rule Control.Access.RoleBased.Internal.Types Snap.Snaplet.Auth.AuthManager Snap.Snaplet.Auth.Types Snap.Snaplet.Auth.Handlers Snap.Snaplet.Auth.Handlers.Errors Snap.Snaplet.Auth.SpliceHelpers Snap.Snaplet.Heist.Internal Snap.Snaplet.Internal.Initializer Snap.Snaplet.Internal.LensT Snap.Snaplet.Internal.Lensed Snap.Snaplet.Internal.RST Snap.Snaplet.Internal.Types Snap.Snaplet.Session.SecureCookie build-depends: MonadCatchIO-transformers >= 0.2 && < 0.4, -- Blacklist aeson versions with problems from lack of upper bounds aeson (>= 0.6 && < 0.7) || (>= 0.7.0.4 && < 0.10), attoparsec >= 0.10 && < 0.14, bytestring >= 0.9.1 && < 0.11, cereal >= 0.3 && < 0.5, clientsession >= 0.8 && < 0.10, comonad >= 1.1 && < 4.3, configurator >= 0.1 && < 0.4, containers >= 0.3 && < 0.6, directory >= 1.0 && < 1.3, directory-tree >= 0.11 && < 0.13, dlist >= 0.5 && < 0.8, either >= 4.3 && < 4.5, filepath >= 1.1 && < 1.5, -- Blacklist bad versions of hashable hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3), heist >= 0.14 && < 0.15, logict >= 0.4.2 && < 0.7, mtl > 2.0 && < 2.3, mwc-random >= 0.8 && < 0.14, pwstore-fast >= 2.2 && < 2.5, regex-posix >= 0.95 && < 1, snap-core >= 0.9 && < 0.11, snap-server >= 0.9 && < 0.11, stm >= 2.2 && < 2.5, text >= 0.11 && < 1.3, time >= 1.1 && < 1.6, transformers >= 0.2 && < 0.5, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.7.1 && < 0.12, vector-algorithms >= 0.4 && < 0.8, xmlhtml >= 0.1 && < 0.3 if flag(old-base) build-depends: base >= 4 && < 4.4, lens >= 3.7.6 && < 3.8 else build-depends: base >= 4.4 && < 5, lens >= 3.7.6 && < 4.13 extensions: BangPatterns, CPP, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, NoMonomorphismRestriction, OverloadedStrings, PackageImports, Rank2Types, RecordWildCards, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeOperators, TypeSynonymInstances if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-orphans -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-orphans Executable snap hs-source-dirs: src main-is: Snap/Starter.hs other-modules: Snap.StarterTH build-depends: base >= 4 && < 5, bytestring >= 0.9.1 && < 0.11, containers >= 0.3 && < 0.6, directory >= 1.0 && < 1.3, directory-tree >= 0.10 && < 0.13, filepath >= 1.1 && < 1.5, -- Blacklist bad versions of hashable hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3), old-time >= 1.0 && < 1.2, snap-server >= 0.9 && < 0.11, template-haskell >= 2.2 && < 2.11, text >= 0.11 && < 1.3 extensions: OverloadedStrings ghc-prof-options: -prof -auto-all if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-orphans -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-orphans source-repository head type: git location: https://github.com/snapframework/snap.git snap-0.14.0.6/extra/0000755000000000000000000000000012552604453012220 5ustar0000000000000000snap-0.14.0.6/extra/haddock.css0000644000000000000000000002023012552604453014324 0ustar0000000000000000/* -------- Global things --------- */ HTML { background-color: #f0f3ff; width: 100%; } BODY { -moz-border-radius:5px; -webkit-border-radius:5px; width: 50em; margin: 2em auto; padding: 0; background-color: #ffffff; color: #000000; font-size: 110%; font-family: Georgia, serif; } A:link { color: #5200A3; text-decoration: none } A:visited { color: #5200A3; text-decoration: none } A:hover { color: #5200A3; text-decoration: none; border-bottom:#5200A3 dashed 1px; } TABLE.vanilla { width: 100%; border-width: 0px; /* I can't seem to specify cellspacing or cellpadding properly using CSS... */ } DL { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; letter-spacing: -0.01em; margin: 0; } .vanilla .vanilla dl { font-size: 80%; } .vanilla .vanilla dl dl { padding-left: 0; font-size: 95%; } TD.section1, TD.section2, TD.section3, TD.section4, TD.doc, DL { padding: 0 30px 0 34px; } TABLE.vanilla2 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; border-width: 0px; } /* font is a little too small in MSIE */ TT, PRE, CODE { font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; font-size: 90%; } LI P { margin: 0pt } P { margin-top: 0; margin-bottom: 0.75em; } TD { border-width: 0px; } TABLE.narrow { border-width: 0px; } TD.s8 { height: 0; margin:0; padding: 0 } TD.s15 { height: 20px; } SPAN.keyword { text-decoration: underline; } /* Resize the buttom image to match the text size */ IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em } /* --------- Contents page ---------- */ DIV.node { padding-left: 3em; } DIV.cnode { padding-left: 1.75em; } SPAN.pkg { position: absolute; left: 50em; } /* --------- Documentation elements ---------- */ TD FONT { font-weight: bold; letter-spacing: -0.02em; } TD.children { padding-left: 25px; } TD.synopsis { padding: 2px; background-color: #f0f0f0; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; } TD.decl { padding: 4px 8px; background-color: #FAFAFA; border-bottom: #F2F2F2 solid 1px; border-top: #FCFCFC solid 1px; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; vertical-align: top; } TD.decl TD.decl { font-size: 100%; padding: 4px 0; border: 0; } TD.topdecl { padding: 20px 30px 0.5ex 30px; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; ; vertical-align: top; } .vanilla .vanilla .vanilla .topdecl { padding-left: 0; padding-right: 0; } .vanilla .vanilla .vanilla { padding-left: 30px; } .decl .vanilla { padding-left: 0px !important; } .body .vanilla .body { padding-left: 0; padding-right: 0; } .body .vanilla .body .decl { padding-left: 12px; } .body .vanilla .body div .vanilla .decl { padding-left: 12px; } TABLE.declbar { background-color: #f0f0f0; border-spacing: 0px; border-bottom:1px solid #d7d7df; border-right:1px solid #d7d7df; border-top:1px solid #f4f4f9; border-left:1px solid #f4f4f9; padding: 4px; } TD.declname { width: 100%; padding-right: 4px; } TD.declbut { padding-left: 8px; padding-right: 5px; border-left-width: 1px; border-left-color: #000099; border-left-style: solid; white-space: nowrap; font-size: x-small; } /* arg is just like decl, except that wrapping is not allowed. It is used for function and constructor arguments which have a text box to the right, where if wrapping is allowed the text box squashes up the declaration by wrapping it. */ TD.arg { padding: 2px 12px; background-color: #f0f0f0; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; vertical-align: top; white-space: nowrap; } TD.recfield { padding-left: 20px } TD.doc { padding-left: 38px; font-size: 95%; line-height: 1.66; } TD.ndoc { font-size: 95%; line-height: 1.66; padding: 2px 4px 2px 8px; } TD.rdoc { padding: 2px; padding-left: 30px; width: 100%; font-size: 80%; font-style: italic; font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; } TD.body { padding: 0 30px; } TD.pkg { width: 100%; padding-left: 30px } TABLE.indexsearch TR.indexrow { display: none; } TABLE.indexsearch TR.indexshow { display: table-row; } TD.indexentry { vertical-align: top; padding: 0 30px } TD.indexannot { vertical-align: top; padding-left: 20px; white-space: nowrap } TD.indexlinks { width: 100% } /* ------- Section Headings ------- */ TD.section1, TD.section2, TD.section3, TD.section4, TD.section5 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; } TD.section1 { padding-top: 14px; font-weight: bold; letter-spacing: -0.02em; font-size: 140% } TD.section2 { padding-top: 4px; font-weight: bold; letter-spacing: -0.02em; font-size: 120% } TD.section3 { padding-top: 5px; font-weight: bold; letter-spacing: -0.02em; font-size: 105% } TD.section4 { font-weight: bold; padding-top: 12px; padding-bottom: 4px; letter-spacing: -0.02em; font-size: 90% } /* -------------- The title bar at the top of the page */ TD.infohead { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; font-weight: bold; padding: 0 30px; text-align: left; } TD.infoval { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; padding: 0 30px; text-align: left; } TD.topbar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; background-color: #3465a4; padding: 5px; -moz-border-radius-topleft:5px; -moz-border-radius-topright:5px; -webkit-border-radius-topleft:5px; -webkit-border-radius-topright:5px; } TD.title { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; padding-left: 30px; letter-spacing: -0.02em; font-weight: bold; width: 100% } TD.topbut { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; padding-left: 5px; padding-right: 5px; border-left-width: 1px; border-left-color: #ffffff; border-left-style: solid; letter-spacing: -0.02em; font-weight: bold; white-space: nowrap; } TD.topbut A:link { color: #ffffff } TD.topbut A:visited { color: #ffff00 } TD.topbut A:hover { background-color: #C9D3DE; } TD.topbut:hover { background-color: #C9D3DE; } TD.modulebar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #141B24; background-color: #C9D3DE; padding: 5px; border-top-width: 1px; border-top-color: #ffffff; border-top-style: solid; -moz-border-radius-bottomleft:5px; -moz-border-radius-bottomright:5px; -webkit-border-radius-bottomleft:5px; -webkit-border-radius-bottomright:5px; } /* --------- The page footer --------- */ TD.botbar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; -moz-border-radius:5px; -webkit-border-radius:5px; background-color: #3465a4; color: #ffffff; padding: 5px } TD.botbar A:link { color: #ffffff; text-decoration: underline } TD.botbar A:visited { color: #ffff00 } TD.botbar A:hover { background-color: #6060ff } /* --------- Mini Synopsis for Frame View --------- */ .outer { margin: 0 0; padding: 0 0; } .mini-synopsis { padding: 0.25em 0.25em; } .mini-synopsis H1 { font-size: 120%; } .mini-synopsis H2 { font-size: 107%; } .mini-synopsis H3 { font-size: 100%; } .mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; margin-top: 0.5em; margin-bottom: 0.25em; padding: 0 0; font-weight: bold; letter-spacing: -0.02em; } .mini-synopsis H1 { border-bottom: 1px solid #ccc; } .mini-topbar { font-size: 120%; background: #0077dd; padding: 0.25em; } snap-0.14.0.6/extra/hscolour.css0000644000000000000000000000073712552604453014577 0ustar0000000000000000body { font-size: 90%; } pre, code, body { font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; } .hs-keyglyph, .hs-layout {color: #5200A3;} .hs-keyword {color: #3465a4; font-weight: bold;} .hs-comment, .hs-comment a {color: #579; } .hs-str, .hs-chr {color: #141B24;} .hs-keyword, .hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {} snap-0.14.0.6/extra/logo.gif0000644000000000000000000000113712552604453013651 0ustar0000000000000000GIF89a` J"K#M%N(P1W1X3Z6\?d4e=i9i:j=1.2 Executable projname hs-source-dirs: src main-is: Main.hs Build-depends: base >= 4 && < 5, bytestring >= 0.9.1 && < 0.11, MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3, snap-core >= 0.9 && < 0.10, snap-server >= 0.9 && < 0.10 if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-unused-do-bind else ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 snap-0.14.0.6/project_template/barebones/log/0000755000000000000000000000000012552604453017157 5ustar0000000000000000snap-0.14.0.6/project_template/barebones/log/access.log0000644000000000000000000000000012552604453021111 0ustar0000000000000000snap-0.14.0.6/project_template/barebones/src/0000755000000000000000000000000012552604453017165 5ustar0000000000000000snap-0.14.0.6/project_template/barebones/src/Main.hs0000644000000000000000000000110312552604453020400 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Applicative import Snap.Core import Snap.Util.FileServe import Snap.Http.Server main :: IO () main = quickHttpServe site site :: Snap () site = ifTop (writeBS "hello world") <|> route [ ("foo", writeBS "bar") , ("echo/:echoparam", echoHandler) ] <|> dir "static" (serveDirectory ".") echoHandler :: Snap () echoHandler = do param <- getParam "echoparam" maybe (writeBS "must specify echo/param in URL") writeBS param snap-0.14.0.6/project_template/default/0000755000000000000000000000000012552604453016062 5ustar0000000000000000snap-0.14.0.6/project_template/default/.ghci0000644000000000000000000000014512552604453016775 0ustar0000000000000000:set -isrc :set -hide-package MonadCatchIO-mtl :set -hide-package monads-fd :set -XOverloadedStrings snap-0.14.0.6/project_template/default/foo.cabal0000644000000000000000000000421512552604453017633 0ustar0000000000000000Name: 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 Flag development Description: Whether to build the server in development (interpreted) mode Default: False Flag old-base default: False manual: False Executable projname hs-source-dirs: src main-is: Main.hs Build-depends: bytestring >= 0.9.1 && < 0.11, heist >= 0.14 && < 0.15, MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3, snap >= 0.13 && < 0.15, snap-core >= 0.9 && < 0.10, snap-server >= 0.9 && < 0.10, snap-loader-static >= 0.9 && < 0.10, text >= 0.11 && < 1.3, time >= 1.1 && < 1.6, xmlhtml >= 0.1 && < 0.3 if flag(old-base) build-depends: base >= 4 && < 4.4, lens >= 3.7.6 && < 3.8 else build-depends: base >= 4.4 && < 5, lens >= 3.7.6 && < 4.13 if flag(development) build-depends: snap-loader-dynamic == 0.10.* cpp-options: -DDEVELOPMENT -- In development mode, speed is already going to suffer, so skip -- the fancy optimization flags. Additionally, disable all -- warnings. The hint library doesn't give an option to execute -- compiled code when there were also warnings, so disabling -- warnings allows quicker workflow. ghc-options: -threaded -w else if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-orphans -fno-warn-unused-do-bind else ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-orphans snap-0.14.0.6/project_template/default/log/0000755000000000000000000000000012552604453016643 5ustar0000000000000000snap-0.14.0.6/project_template/default/log/access.log0000644000000000000000000000000012552604453020575 0ustar0000000000000000snap-0.14.0.6/project_template/default/log/error.log0000644000000000000000000000000012552604453020465 0ustar0000000000000000snap-0.14.0.6/project_template/default/snaplets/0000755000000000000000000000000012552604453017713 5ustar0000000000000000snap-0.14.0.6/project_template/default/snaplets/heist/0000755000000000000000000000000012552604453021027 5ustar0000000000000000snap-0.14.0.6/project_template/default/snaplets/heist/templates/0000755000000000000000000000000012552604453023025 5ustar0000000000000000snap-0.14.0.6/project_template/default/snaplets/heist/templates/_login.tpl0000644000000000000000000000034712552604453025021 0ustar0000000000000000

Snap Example App Login

/login Login

Don't have a login yet? Create a new user

snap-0.14.0.6/project_template/default/snaplets/heist/templates/_new_user.tpl0000644000000000000000000000021212552604453025527 0ustar0000000000000000

Register a new user

/new_user Add User snap-0.14.0.6/project_template/default/snaplets/heist/templates/base.tpl0000644000000000000000000000032312552604453024456 0ustar0000000000000000 Snap web server
snap-0.14.0.6/project_template/default/snaplets/heist/templates/index.tpl0000644000000000000000000000067212552604453024662 0ustar0000000000000000

This is a simple demo page served using Heist and the Snap web framework.

Congrats! You're logged in as ''

Logout

 snap-0.14.0.6/project_template/default/snaplets/heist/templates/login.tpl0000644000000000000000000000007612552604453024661 0ustar0000000000000000 snap-0.14.0.6/project_template/default/snaplets/heist/templates/new_user.tpl0000644000000000000000000000010212552604453025366 0ustar0000000000000000 snap-0.14.0.6/project_template/default/snaplets/heist/templates/userform.tpl0000644000000000000000000000057112552604453025413 0ustar0000000000000000
Login:
Password:
snap-0.14.0.6/project_template/default/src/0000755000000000000000000000000012552604453016651 5ustar0000000000000000snap-0.14.0.6/project_template/default/src/Application.hs0000644000000000000000000000151312552604453021450 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------ -- | This module defines our application's state type and an alias for its -- handler monad. module Application where ------------------------------------------------------------------------------ import Control.Lens import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Snaplet.Auth import Snap.Snaplet.Session ------------------------------------------------------------------------------ data App = App { _heist :: Snaplet (Heist App) , _sess :: Snaplet SessionManager , _auth :: Snaplet (AuthManager App) } makeLenses ''App instance HasHeist App where heistLens = subSnaplet heist ------------------------------------------------------------------------------ type AppHandler = Handler App App snap-0.14.0.6/project_template/default/src/Main.hs0000644000000000000000000001160412552604453020073 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {- NOTE: Don't modify this file unless you know what you are doing. If you are new to snap, start with Site.hs and Application.hs. This file contains boilerplate needed for dynamic reloading and is not meant for general consumption. Occasionally if we modify the way the dynamic reloader works and you want to upgrade, you might have to swap out this file for a newer version. But in most cases you'll never need to modify this code. -} module Main where ------------------------------------------------------------------------------ import Control.Exception (SomeException, try) import qualified Data.Text as T import Snap.Http.Server import Snap.Snaplet import Snap.Snaplet.Config import Snap.Core import System.IO import Site #ifdef DEVELOPMENT import Snap.Loader.Dynamic #else import Snap.Loader.Static #endif ------------------------------------------------------------------------------ -- | This is the entry point for this web server application. It supports -- easily switching between interpreting source and running statically compiled -- code. -- -- In either mode, the generated program should be run from the root of the -- project tree. When it is run, it locates its templates, static content, and -- source files in development mode, relative to the current working directory. -- -- When compiled with the development flag, only changes to the libraries, your -- cabal file, or this file should require a recompile to be picked up. -- Everything else is interpreted at runtime. There are a few consequences of -- this. -- -- First, this is much slower. Running the interpreter takes a significant -- chunk of time (a couple tenths of a second on the author's machine, at this -- time), regardless of the simplicity of the loaded code. In order to -- recompile and re-load server state as infrequently as possible, the source -- directories are watched for updates, as are any extra directories specified -- below. -- -- Second, the generated server binary is MUCH larger, since it links in the -- GHC API (via the hint library). -- -- Third, and the reason you would ever want to actually compile with -- development mode, is that it enables a faster development cycle. You can -- simply edit a file, save your changes, and hit reload to see your changes -- reflected immediately. -- -- When this is compiled without the development flag, all the actions are -- statically compiled in. This results in faster execution, a smaller binary -- size, and having to recompile the server for any code change. -- main :: IO () main = do -- Depending on the version of loadSnapTH in scope, this either enables -- dynamic reloading, or compiles it without. The last argument to -- loadSnapTH is a list of additional directories to watch for changes to -- trigger reloads in development mode. It doesn't need to include source -- directories, those are picked up automatically by the splice. (conf, site, cleanup) <- $(loadSnapTH [| getConf |] 'getActions ["snaplets/heist/templates"]) _ <- try $ httpServe conf site :: IO (Either SomeException ()) cleanup ------------------------------------------------------------------------------ -- | This action loads the config used by this application. The loaded config -- is returned as the first element of the tuple produced by the loadSnapTH -- Splice. The type is not solidly fixed, though it must be an IO action that -- produces the same type as 'getActions' takes. It also must be an instance of -- Typeable. If the type of this is changed, a full recompile will be needed to -- pick up the change, even in development mode. -- -- This action is only run once, regardless of whether development or -- production mode is in use. getConf :: IO (Config Snap AppConfig) getConf = commandLineAppConfig defaultConfig ------------------------------------------------------------------------------ -- | This function generates the the site handler and cleanup action from the -- configuration. In production mode, this action is only run once. In -- development mode, this action is run whenever the application is reloaded. -- -- Development mode also makes sure that the cleanup actions are run -- appropriately before shutdown. The cleanup action returned from loadSnapTH -- should still be used after the server has stopped handling requests, as the -- cleanup actions are only automatically run when a reload is triggered. -- -- This sample doesn't actually use the config passed in, but more -- sophisticated code might. getActions :: Config Snap AppConfig -> IO (Snap (), IO ()) getActions conf = do (msgs, site, cleanup) <- runSnaplet (appEnvironment =<< getOther conf) app hPutStrLn stderr $ T.unpack msgs return (site, cleanup) snap-0.14.0.6/project_template/default/src/Site.hs0000644000000000000000000000647512552604453020125 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ -- | This module is where all the routes and handlers are defined for your -- site. The 'app' function is the initializer that combines everything -- together and is exported by this module. module Site ( app ) where ------------------------------------------------------------------------------ import Control.Applicative import Data.ByteString (ByteString) import Data.Monoid import qualified Data.Text as T import Snap.Core import Snap.Snaplet import Snap.Snaplet.Auth import Snap.Snaplet.Auth.Backends.JsonFile import Snap.Snaplet.Heist import Snap.Snaplet.Session.Backends.CookieSession import Snap.Util.FileServe import Heist import qualified Heist.Interpreted as I ------------------------------------------------------------------------------ import Application ------------------------------------------------------------------------------ -- | Render login form handleLogin :: Maybe T.Text -> Handler App (AuthManager App) () handleLogin authError = heistLocal (I.bindSplices errs) $ render "login" where errs = maybe mempty splice authError splice err = "loginError" ## I.textSplice err ------------------------------------------------------------------------------ -- | Handle login submit handleLoginSubmit :: Handler App (AuthManager App) () handleLoginSubmit = loginUser "login" "password" Nothing (\_ -> handleLogin err) (redirect "/") where err = Just "Unknown user or password" ------------------------------------------------------------------------------ -- | Logs out and redirects the user to the site index. handleLogout :: Handler App (AuthManager App) () handleLogout = logout >> redirect "/" ------------------------------------------------------------------------------ -- | Handle new user form submit handleNewUser :: Handler App (AuthManager App) () handleNewUser = method GET handleForm <|> method POST handleFormSubmit where handleForm = render "new_user" handleFormSubmit = registerUser "login" "password" >> redirect "/" ------------------------------------------------------------------------------ -- | The application's routes. routes :: [(ByteString, Handler App App ())] routes = [ ("/login", with auth handleLoginSubmit) , ("/logout", with auth handleLogout) , ("/new_user", with auth handleNewUser) , ("", serveDirectory "static") ] ------------------------------------------------------------------------------ -- | The application initializer. app :: SnapletInit App App app = makeSnaplet "app" "An snaplet example application." Nothing $ do h <- nestSnaplet "" heist $ heistInit "templates" s <- nestSnaplet "sess" sess $ initCookieSessionManager "site_key.txt" "sess" (Just 3600) -- NOTE: We're using initJsonFileAuthManager here because it's easy and -- doesn't require any kind of database server to run. In practice, -- you'll probably want to change this to a more robust auth backend. a <- nestSnaplet "auth" auth $ initJsonFileAuthManager defAuthSettings sess "users.json" addRoutes routes addAuthSplices h auth return $ App h s a snap-0.14.0.6/project_template/default/static/0000755000000000000000000000000012552604453017351 5ustar0000000000000000snap-0.14.0.6/project_template/default/static/screen.css0000644000000000000000000000053012552604453021340 0ustar0000000000000000html { padding: 0; margin: 0; background-color: #ffffff; font-family: Verdana, Helvetica, sans-serif; } body { padding: 0; margin: 0; } a { text-decoration: underline; } a :hover { cursor: pointer; text-decoration: underline; } img { border: none; } #content { padding-left: 1em; } #info { font-size: 60%; } snap-0.14.0.6/project_template/tutorial/0000755000000000000000000000000012552604453016301 5ustar0000000000000000snap-0.14.0.6/project_template/tutorial/.ghci0000644000000000000000000000014512552604453017214 0ustar0000000000000000:set -isrc :set -hide-package MonadCatchIO-mtl :set -hide-package monads-fd :set -XOverloadedStrings snap-0.14.0.6/project_template/tutorial/foo.cabal0000644000000000000000000000243112552604453020050 0ustar0000000000000000Name: 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 Flag old-base default: False manual: False Executable projname hs-source-dirs: src main-is: Tutorial.lhs Build-depends: bytestring >= 0.9.1 && < 0.11, MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3, snap >= 0.11 && < 0.15, snap-core >= 0.9 && < 0.10, snap-server >= 0.9 && < 0.10 if flag(old-base) build-depends: base >= 4 && < 4.4, lens >= 3.7.6 && < 3.8 else build-depends: base >= 4.4 && < 5, lens >= 3.7.6 && < 4.13 if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-unused-do-bind else ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 snap-0.14.0.6/project_template/tutorial/log/0000755000000000000000000000000012552604453017062 5ustar0000000000000000snap-0.14.0.6/project_template/tutorial/log/placeholder0000644000000000000000000000001412552604453021262 0ustar0000000000000000placeholder snap-0.14.0.6/project_template/tutorial/src/0000755000000000000000000000000012552604453017070 5ustar0000000000000000snap-0.14.0.6/project_template/tutorial/src/Part2.lhs0000644000000000000000000000056012552604453020571 0ustar0000000000000000> {-# LANGUAGE OverloadedStrings #-} > module Part2 where > import Snap.Snaplet > data Foo = Foo > > data Bar = Bar > > fooInit :: SnapletInit b Foo > fooInit = makeSnaplet "foo" "Foo snaplet" Nothing $ do > return Foo > > barInit :: SnapletLens b Foo -> SnapletInit b Bar > barInit h = makeSnaplet "bar" "Bar snaplet" Nothing $ do > return Bar snap-0.14.0.6/project_template/tutorial/src/Tutorial.lhs0000644000000000000000000004141712552604453021412 0ustar0000000000000000What Are Snaplets? ================== A snaplet is a composable web application. Snaplets allow you to build self-contained pieces of functionality and glue them together to make larger applications. Here are some of the things provided by the snaplet API: - Infrastructure for application state/environment - Snaplet initialization, reload, and cleanup - Management of filesystem data and automatic snaplet installation - Unified config file infrastructure One example might be a wiki snaplet. It would be distributed as a haskell package that would be installed with cabal and would probably include code, config files, HTML templates, stylesheets, JavaScript, images, etc. The snaplet's code would provide the necessary API to let your application interact seamlessly with the wiki functionality. When you run your application for the first time, all of the wiki snaplet's filesystem resources will automatically be copied into the appropriate places. Then you will immediately be able to customize the wiki to fit your needs by editing config files, providing your own stylesheets, etc. We will discuss this in more detail later. A snaplet can represent anything from backend Haskell infrastructure with no user facing functionality to a small widget like a chat box that goes in the corner of a web page to an entire standalone website like a blog or forum. The possibilities are endless. A snaplet is a web application, and web applications are snaplets. This means that using snaplets and writing snaplets are almost the same thing, and it's trivial to drop a whole website into another one. We're really excited about the possibilities available with snaplets. In fact, Snap already ships with snaplets for sessions, authentication, and templating (with Heist), This gives you useful functionality out of the box, and jump starts your own snaplet development by demonstrating some useful design patterns. So without further ado, let's get started. Snaplet Overview ================ The heart of the snaplets infrastructure is state management. Most nontrivial pieces of a web app need some kind of state or environment data. Components that do not need any kind of state or environment are probably more appropriate as a standalone library than as a snaplet. Before we continue, we must clarify an important point. The Snap web server processes each request in its own green thread. This means that each request will receive a separate copy of the state defined by your application and snaplets, and modifications to that state only affect the local thread that generates a single response. From now on, when we talk about state this is what we are talking about. If you need global application state, you have to use a thread-safe construct such as an MVar or IORef. This post is written in literate Haskell. It uses a small external module called Part2 that is [available here](https://github.com/snapframework/snap/blob/master/project_template/tutorial/src/Part2.lhs). You can also install the full code in the current directory with the command `snap init tutorial`. First we need to get imports out of the way. > {-# LANGUAGE TemplateHaskell #-} > {-# LANGUAGE OverloadedStrings #-} > > module Main where > > import Control.Applicative > import Control.Lens.TH > import Control.Monad.State > import Control.Monad.Trans > import qualified Data.ByteString.Char8 as B > import Data.IORef > import Data.Maybe > import Snap > import Snap.Snaplet.Heist > import Part2 We start our application by defining a data structure to hold the state. This data structure includes the state of all snaplets (wrapped in a Snaplet) used by our application as well as any other state we might want. > data App = App > { _heist :: Snaplet (Heist App) > , _foo :: Snaplet Foo > , _bar :: Snaplet Bar > , _companyName :: IORef B.ByteString > } > > makeLenses ''App The field names begin with an underscore because of some more complicated things going on under the hood. However, all you need to know right now is that you should prefix things with an underscore and then call `makeLenses`. This lets you use the names without an underscore in the rest of your application. The next thing we need to do is define an initializer. > appInit :: SnapletInit App App > appInit = makeSnaplet "myapp" "My example application" Nothing $ do > hs <- nestSnaplet "heist" heist $ heistInit "templates" > fs <- nestSnaplet "foo" foo $ fooInit > bs <- nestSnaplet "" bar $ nameSnaplet "newname" $ barInit foo > addRoutes [ ("/hello", writeText "hello world") > , ("/fooname", with foo namePage) > , ("/barname", with bar namePage) > , ("/company", companyHandler) > ] > wrapSite (<|> heistServe) > ref <- liftIO $ newIORef "fooCorp" > return $ App hs fs bs ref For now don't worry about all the details of this code. We'll work through the individual pieces one at a time. The basic idea here is that to initialize an application, we first initialize each of the snaplets, add some routes, run a function wrapping all the routes, and return the resulting state data structure. This example demonstrates the use of a few of the most common snaplet functions. nestSnaplet ----------- All calls to child snaplet initializer functions must be wrapped in a call to nestSnaplet. The first parameter is a URL path segment that is used to prefix all routes defined by the snaplet. This lets you ensure that there will be no problems with duplicate routes defined in different snaplets. If the foo snaplet defines a route `/foopage`, then in the above example, that page will be available at `/foo/foopage`. Sometimes though, you might want a snaplet's routes to be available at the top level. To do that, just pass an empty string to nestSnaplet as shown above with the bar snaplet. In our example above, the bar snaplet does something that needs to know about the foo snaplet. Maybe foo is a database snaplet and bar wants to store or read something. In order to make that happen, it needs to have a "handle" to the snaplet. Our handles are whatever field names we used in the App data structure minus the initial underscore character. They are automatically generated by the `makeLenses` function. For now it's sufficient to think of them as a getter and a setter combined (to use an OO metaphor). The second parameter to nestSnaplet is the lens to the snaplet you're nesting. In order to place a piece into the puzzle, you need to know where it goes. nameSnaplet ----------- The author of a snaplet defines a default name for the snaplet in the first argument to the makeSnaplet function. This name is used for the snaplet's directory in the filesystem. If you don't want to use the default name, you can override it with the `nameSnaplet` function. Also, if you want to have two instances of the same snaplet, then you will need to use `nameSnaplet` to give at least one of them a unique name. addRoutes --------- The `addRoutes` function is how an application (or snaplet) defines its routes. Under the hood the snaplet infrastructure merges all the routes from all snaplets, prepends prefixes from `nestSnaplet` calls, and passes the list to Snap's [route](http://hackage.haskell.org/packages/archive/snap-core/0.5.1.4/doc/html/Snap-Types.html#v:route) function. A route is a tuple of a URL and a handler function that will be called when the URL is requested. Handler is a wrapper around the Snap monad that handles the snaplet's infrastructure. During initialization, snaplets use the `Initializer` monad. During runtime, they use the `Handler` monad. We'll discuss `Handler` in more detail later. If you're familiar with Snap's old extension system, you can think of it as roughly equivalent to the Application monad. It has a `MonadState` instance that lets you access and modify the current snaplet's state, and a `MonadSnap` instance providing the request-processing functions defined in Snap.Types. wrapSite ------------ `wrapSite` allows you to apply an arbitrary `Handler` transformation to the top-level handler. This is useful if you want to do some generic processing at the beginning or end of every request. For instance, a session snaplet might use it to touch a session activity token before routing happens. It could also be used to implement custom logging. The example above uses it to define heistServe (provided by the Heist snaplet) as the default handler to be tried if no other handler matched. This may seem like an easy way to define routes, but if you string them all together in this way each handler will be evaluated sequentially and you'll get O(n) time complexity, whereas routes defined with `addRoutes` have O(log n) time complexity. Therefore, in a real-world application you would probably want to have `("", heistServe)` in the list passed to `addRoutes`. with ---- The last unfamiliar function in the example is `with`. Here it accompanies a call to the function `namePage`. `namePage` is a simple example handler and looks like this. > namePage :: Handler b v () > namePage = do > mname <- getSnapletName > writeText $ fromMaybe "This shouldn't happen" mname This function is a generic handler that gets the name of the current snaplet and writes it into the response with the `writeText` function defined by the snap-core project. The type variables 'b' and 'v' indicate that this function will work in any snaplet with any base application. The 'with' function is used to run `namePage` in the context of the snaplets foo and bar for the corresponding routes. Site Reloading -------------- Snaplet Initializers serve dual purpose as both initializers and reloaders. Reloads are triggered by a special handler that is bound to the `/admin/reload` route. This handler re-runs the site initializer and if it is successful, loads the newly generated in-memory state. To prevent denial of service attacks, the reload route is only accessible from localhost. If there are any errors during reload, you would naturally want to see them in the HTTP response returned by the server. However, when these same initializers are run when you first start your app, you will want to see status messages printed to the console. To make this possible we provide the `printInfo` function. You should use it to output any informational messages generated by your initializers. If you print directly to standard output or standard error, then those messages will not be available in your browser when you reload the site. Working with state ------------------ `Handler b v` has a `MonadState v` instance. This means that you can access all your snaplet state through the get, put, gets, and modify functions that are probably familiar from the state monad. In our example application we demonstrate this with `companyHandler`. > companyHandler :: Handler App App () > companyHandler = method GET getter <|> method POST setter > where > getter = do > nameRef <- gets _companyName > name <- liftIO $ readIORef nameRef > writeBS name > setter = do > mname <- getParam "name" > nameRef <- gets _companyName > liftIO $ maybe (return ()) (writeIORef nameRef) mname > getter If you set a GET request to `/company`, you'll get the string "fooCorp" back. If you send a POST request, it will set the IORef held in the `_companyName` field in the `App` data structure to the value of the `name` field. Then it calls the getter to return that value back to you so you can see it was actually changed. Again, remember that this change only persists across requests because we used an IORef. If `_companyName` was just a plain string and we had used modify, the changed result would only be visible in the rest of the processing for that request. The Heist Snaplet ================= The astute reader might ask why there is no `with heist` in front of the call to `heistServe`. And indeed, that would normally be the case. But we decided that an application will never need more than one instance of a Heist snaplet. So we provided a type class called `HasHeist` that allows an application to define the global reference to its Heist snaplet by writing a `HasHeist` instance. In this example we define the instance as follows: > instance HasHeist App where heistLens = subSnaplet heist Now all we need is a simple main function to serve our application. > main :: IO () > main = serveSnaplet defaultConfig appInit This completes a full working application. We did leave out a little dummy code for the Foo and Bar snaplets. This code is included in Part2.hs. For more information look in our [API documentation](http://hackage.haskell.org/package/snap), specifically the Snap.Snaplet module. No really, that wasn't a joke. The API docs are written as prose. They should be very easy to read, while having the benefit of including all the actual type signatures. Filesystem Data and Automatic Installation ========================================== Some snaplets will have data stored in the filesystem that should be installed into the directory of any project that uses it. Here's an example of what a snaplet filesystem layout might look like: foosnaplet/ |-- *devel.cfg* |-- db.cfg |-- public/ |-- stylesheets/ |-- images/ |-- js/ |-- *snaplets/* |-- *heist/* |-- templates/ |-- subsnaplet1/ |-- subsnaplet2/ Only the starred items are actually enforced by current code, but we want to establish the others as a convention. The file devel.cfg is automatically read by the snaplet infrastructure. It is available to you via the `getSnapletUserConfig` function. Config files use the format defined by Bryan O'Sullivan's excellent [configurator package](http://hackage.haskell.org/package/configurator). In this example, the user has chosen to put db config items in a separate file and use configurator's import functionality to include it in devel.cfg. If foosnaplet uses `nestSnaplet` or `embedSnaplet` to include any other snaplets, then filesystem data defined by those snaplets will be included in subdirectories under the `snaplets/` directory. So how do you tell the snaplet infrastructure that your snaplet has filesystem data that should be installed? Look at the definition of appInit above. The third argument to the makeSnaplet function is where we specify the filesystem directory that should be installed. That argument has the type `Maybe (IO FilePath)`. In this case we used `Nothing` because our simple example doesn't have any filesystem data. As an example, let's say you are creating a snaplet called killerapp that will be distributed as a hackage project called snaplet-killerapp. Your project directory structure will look something like this: snaplet-killerapp/ |-- resources/ |-- snaplet-killerapp.cabal |-- src/ All of the files and directories listed above under foosnaplet/ will be in resources/. Somewhere in the code you will define an initializer for the snaplet that will look like this: killerInit = makeSnaplet "killerapp" "42" (Just dataDir) $ do The primary function of Cabal is to install code. But it has the ability to install data files and provides a function called `getDataDir` for retrieving the location of these files. Since it returns a different result depending on what machine you're using, the third argument to `makeSnaplet` has to be `Maybe (IO FilePath)` instead of the more natural pure version. To make things more organized, we use the convention of putting all your snaplet's data files in a subdirectory called resources. So we need to create a small function that appends `/resources` to the result of `getDataDir`. import Paths_snaplet_killerapp dataDir = liftM (++"/resources") getDataDir If our project is named snaplet-killerapp, the `getDataDir` function is defined in the module Paths_snaplet_killerapp, which we have to import. To make everything work, you have to tell Cabal about your data files by including a section like the following in snaplet-killerapp.cabal: data-files: resources/devel.cfg, resources/public/stylesheets/style.css, resources/snaplets/heist/templates/page.tpl Now whenever your snaplet is used, its filesystem data will be automagically copied into the local project that is using it, whenever the application is run and it sees that the snaplet's directory does not already exist. If the user upgrades to a new version of the snaplet and the new version made changes to the filesystem resources, those resources will NOT be automatically copied in by default. Resource installation *only* happens when the `snaplets/foo` directory does not exist. If you want to get the latest version of the filesystem resources, remove the `snaplets/foo` directory, and restart your app. snap-0.14.0.6/src/0000755000000000000000000000000012552604453011664 5ustar0000000000000000snap-0.14.0.6/src/Snap.hs0000644000000000000000000000060212552604453013117 0ustar0000000000000000{-| This module provides convenience exports of the modules most commonly used when developing with the Snap Framework. For documentation about Snaplets, see "Snap.Snaplet". For the core web server API, see "Snap.Core". -} module Snap ( module Snap.Core , module Snap.Http.Server , module Snap.Snaplet ) where import Snap.Core import Snap.Http.Server import Snap.Snaplet snap-0.14.0.6/src/Control/0000755000000000000000000000000012552604453013304 5ustar0000000000000000snap-0.14.0.6/src/Control/Access/0000755000000000000000000000000012552604453014505 5ustar0000000000000000snap-0.14.0.6/src/Control/Access/RoleBased/0000755000000000000000000000000012552604453016345 5ustar0000000000000000snap-0.14.0.6/src/Control/Access/RoleBased/Checker.hs0000644000000000000000000001572212552604453020254 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Control.Access.RoleBased.Checker where ------------------------------------------------------------------------------ import Control.Monad import Control.Monad.Logic import Control.Monad.Reader import Control.Monad.State.Lazy import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) ------------------------------------------------------------------------------ import Control.Access.RoleBased.Internal.RoleMap (RoleMap) import qualified Control.Access.RoleBased.Internal.RoleMap as RM import Control.Access.RoleBased.Internal.Types import Control.Access.RoleBased.Role ------------------------------------------------------------------------------ type RoleBuilder a = StateT RoleMap RoleMonad a ------------------------------------------------------------------------------ applyRule :: Role -> Rule -> [Role] applyRule r (Rule _ f) = f r ------------------------------------------------------------------------------ applyRuleSet :: Role -> RuleSet -> [Role] applyRuleSet r (RuleSet m) = f r where f = fromMaybe (const []) $ M.lookup (_roleName r) m ------------------------------------------------------------------------------ checkUnseen :: Role -> RoleBuilder () checkUnseen role = do m <- get if isJust $ RM.lookup role m then mzero else return () ------------------------------------------------------------------------------ checkSeen :: Role -> RoleBuilder () checkSeen = lnot . checkUnseen ------------------------------------------------------------------------------ markSeen :: Role -> RoleBuilder () markSeen role = modify $ RM.insert role ------------------------------------------------------------------------------ isum :: (MonadLogic m, MonadPlus m) => [m a] -> m a isum l = case l of [] -> mzero (x:xs) -> x `interleave` isum xs ------------------------------------------------------------------------------ -- | Given a set of roles to check, and a set of implication rules describing -- how a given role inherits from other roles, this function produces a stream -- of expanded Roles. If a Role is seen twice, expandRoles mzeros. expandRoles :: [Rule] -> [Role] -> RoleMonad Role expandRoles rules roles0 = evalStateT (go roles0) RM.empty where ruleSet = rulesToSet rules go roles = isum $ map expandOne roles expandOne role = do checkUnseen role markSeen role return role `interleave` go newRoles where newRoles = applyRuleSet role ruleSet ------------------------------------------------------------------------------ hasRole :: Role -> RuleChecker () hasRole r = RuleChecker $ do ch <- ask once $ go ch where go gen = do r' <- lift gen if r `matches` r' then return () else mzero ------------------------------------------------------------------------------ missingRole :: Role -> RuleChecker () missingRole = lnot . hasRole ------------------------------------------------------------------------------ hasAllRoles :: [Role] -> RuleChecker () hasAllRoles rs = RuleChecker $ do ch <- ask lift $ once $ go ch $ RM.fromList rs where go gen !st = do mr <- msplit gen maybe mzero (\(r,gen') -> let st' = RM.delete r st in if RM.null st' then return () else go gen' st') mr ------------------------------------------------------------------------------ hasAnyRoles :: [Role] -> RuleChecker () hasAnyRoles rs = RuleChecker $ do ch <- ask lift $ once $ go ch where st = RM.fromList rs go gen = do mr <- msplit gen maybe mzero (\(r,gen') -> if isJust $ RM.lookup r st then return () else go gen') mr ------------------------------------------------------------------------------ runRuleChecker :: [Rule] -> [Role] -> RuleChecker a -> Bool runRuleChecker rules roles (RuleChecker f) = case outs of [] -> False _ -> True where (RoleMonad st) = runReaderT f $ expandRoles rules roles outs = observeMany 1 st ------------------------------------------------------------------------------ mkRule :: Text -> (Role -> [Role]) -> Rule mkRule = Rule ------------------------------------------------------------------------------ implies :: Role -> [Role] -> Rule implies src dest = Rule (_roleName src) (\role -> if role `matches` src then dest else []) ------------------------------------------------------------------------------ impliesWith :: Role -> (HashMap Text RoleValue -> [Role]) -> Rule impliesWith src f = Rule (_roleName src) (\role -> if src `matches` role then f $ _roleData role else []) ------------------------------------------------------------------------------ -- Testing code follows: TODO: move into test suite testRules :: [Rule] testRules = [ "user" `implies` ["guest", "can_post"] , "superuser" `implies` [ "user" , "can_moderate" , "can_administrate"] , "superuser" `implies` [ addRoleData "arg" "*" "with_arg" ] , "with_arg" `impliesWith` \dat -> maybe [] (\arg -> [addRoleData "arg" arg "dependent_arg"]) $ M.lookup "arg" dat , "superuser" `implies` [ addRoleData "arg1" "a" $ addRoleData "arg2" "b" "multi_args" ] ] tX :: RuleChecker () -> Bool tX f = runRuleChecker testRules ["superuser"] f t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17 :: Bool t1 = tX $ hasAnyRoles ["guest","userz"] t2 = tX $ hasAllRoles ["guest","userz"] t3 = tX $ hasAllRoles ["guest","user"] t4 = tX $ hasRole "can_administrate" t5 = tX $ hasRole "lkfdhjkjfhds" t6 = tX $ do hasRole "guest" hasRole "superuser" t7 = tX $ do hasRole "zzzzz" hasRole "superuser" t8 = tX $ hasRole $ addRoleData "arg" "*" "dependent_arg" t9 = tX $ hasRole "multi_args" t10 = tX $ hasRole $ addRoleData "arg2" "b" "multi_args" t11 = tX $ hasRole $ addRoleData "arg2" "z" "multi_args" t12 = tX $ hasAllRoles [addRoleData "arg2" "b" "multi_args"] t13 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args" , addRoleData "arg2" "b" "multi_args" ] t14 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args" , addRoleData "arg2" "aaa" "multi_args" ] t15 = tX $ missingRole "jflsdkjf" t16 = tX $ do missingRole "fdjlksjlf" hasRole "multi_args" t17 = tX $ missingRole "multi_args" snap-0.14.0.6/src/Control/Access/RoleBased/Role.hs0000644000000000000000000000154412552604453017606 0ustar0000000000000000module Control.Access.RoleBased.Role where ------------------------------------------------------------------------------ import qualified Data.HashMap.Strict as M import Control.Access.RoleBased.Internal.Types import Data.Text (Text) ------------------------------------------------------------------------------ matches :: Role -> Role -> Bool matches (Role a1 d1) (Role a2 d2) = a1 == a2 && dmatch (toSortedList d1) (toSortedList d2) where dmatch [] _ = True dmatch _ [] = False dmatch dds@(d:ds) (e:es) = case compare d e of LT -> False EQ -> dmatch ds es GT -> dmatch dds es ------------------------------------------------------------------------------ addRoleData :: Text -> RoleValue -> Role -> Role addRoleData k v (Role n d) = Role n $ M.insert k v d snap-0.14.0.6/src/Control/Access/RoleBased/Types.hs0000644000000000000000000000056712552604453020015 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Control.Access.RoleBased.Types ( Role(..) -- fixme: remove (..) , RoleValue(..) -- fixme , RoleValueMeta(..) , RoleDataDefinition(..) , RoleMetadata(..) , Rule , RuleChecker ) where import Control.Access.RoleBased.Internal.Types snap-0.14.0.6/src/Control/Access/RoleBased/Internal/0000755000000000000000000000000012552604453020121 5ustar0000000000000000snap-0.14.0.6/src/Control/Access/RoleBased/Internal/Role.hs0000644000000000000000000000555012552604453021363 0ustar0000000000000000module Control.Access.RoleBased.Internal.Role where ------------------------------------------------------------------------------ import Control.Monad.ST import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.String import Data.Text (Text) import qualified Data.Vector as V import qualified Data.Vector.Algorithms.Merge as VA ------------------------------------------------------------------------------ data RoleValue = RoleBool Bool | RoleText Text | RoleInt Int | RoleDouble Double deriving (Ord, Eq, Show) ------------------------------------------------------------------------------ instance IsString RoleValue where fromString = RoleText . fromString ------------------------------------------------------------------------------ instance Hashable RoleValue where hashWithSalt salt (RoleBool e) = hashWithSalt salt e `hashWithSalt` (7 :: Int) hashWithSalt salt (RoleText t) = hashWithSalt salt t `hashWithSalt` (196613 :: Int) hashWithSalt salt (RoleInt i) = hashWithSalt salt i `hashWithSalt` (12582917 :: Int) hashWithSalt salt (RoleDouble d) = hashWithSalt salt d `hashWithSalt` (1610612741 :: Int) ------------------------------------------------------------------------------ data Role = Role { _roleName :: Text , _roleData :: HashMap Text RoleValue } deriving (Eq, Show) ------------------------------------------------------------------------------ instance IsString Role where fromString s = Role (fromString s) M.empty ------------------------------------------------------------------------------ toSortedList :: (Ord k, Ord v) => HashMap k v -> [(k,v)] toSortedList m = runST $ do v <- V.unsafeThaw $ V.fromList $ M.toList m VA.sort v v' <- V.unsafeFreeze v return $ V.toList v' ------------------------------------------------------------------------------ instance Hashable Role where hashWithSalt salt (Role nm dat) = h $ hashWithSalt salt nm where h s = hashWithSalt s $ toSortedList dat ------------------------------------------------------------------------------ data RoleValueMeta = RoleBoolMeta | RoleTextMeta | RoleEnumMeta [Text] | RoleIntMeta | RoleDoubleMeta ------------------------------------------------------------------------------ data RoleDataDefinition = RoleDataDefinition { _roleDataName :: Text , _roleValueMeta :: RoleValueMeta , _roleDataDescription :: Text } ------------------------------------------------------------------------------ data RoleMetadata = RoleMetadata { _roleMetadataName :: Text , _roleDescription :: Text , _roleDataDefs :: [RoleDataDefinition] } snap-0.14.0.6/src/Control/Access/RoleBased/Internal/RoleMap.hs0000644000000000000000000000412012552604453022011 0ustar0000000000000000module Control.Access.RoleBased.Internal.RoleMap where ------------------------------------------------------------------------------ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.HashSet (HashSet) import qualified Data.HashSet as S import Data.List (find, foldl') import Data.Text (Text) ------------------------------------------------------------------------------ import Control.Access.RoleBased.Role import Control.Access.RoleBased.Internal.Types ------------------------------------------------------------------------------ newtype RoleMap = RoleMap (HashMap Text (HashSet Role)) ------------------------------------------------------------------------------ fromList :: [Role] -> RoleMap fromList = RoleMap . foldl' ins M.empty where ins m role = M.insertWith S.union (_roleName role) (S.singleton role) m ------------------------------------------------------------------------------ lookup :: Role -> RoleMap -> Maybe Role lookup role (RoleMap m) = find (`matches` role) l where l = maybe [] S.toList $ M.lookup (_roleName role) m ------------------------------------------------------------------------------ delete :: Role -> RoleMap -> RoleMap delete role (RoleMap m) = RoleMap $ maybe m upd $ M.lookup rNm m where rNm = _roleName role upd s = maybe m (\r -> let s' = S.delete r s in if S.null s' then M.delete rNm m else M.insert rNm s' m) (find (`matches` role) $ S.toList s) ------------------------------------------------------------------------------ insert :: Role -> RoleMap -> RoleMap insert role (RoleMap m) = RoleMap $ M.insertWith S.union (_roleName role) (S.singleton role) m ------------------------------------------------------------------------------ empty :: RoleMap empty = RoleMap M.empty ------------------------------------------------------------------------------ null :: RoleMap -> Bool null (RoleMap m) = M.null m snap-0.14.0.6/src/Control/Access/RoleBased/Internal/Rule.hs0000644000000000000000000000253412552604453021370 0ustar0000000000000000module Control.Access.RoleBased.Internal.Rule where ------------------------------------------------------------------------------ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.List (foldl') import Data.Monoid import Data.Text (Text) ------------------------------------------------------------------------------ import Control.Access.RoleBased.Internal.Role ------------------------------------------------------------------------------ data Rule = Rule Text (Role -> [Role]) ------------------------------------------------------------------------------ newtype RuleSet = RuleSet (HashMap Text (Role -> [Role])) ------------------------------------------------------------------------------ instance Monoid RuleSet where mempty = RuleSet M.empty (RuleSet m1) `mappend` (RuleSet m2) = RuleSet $ M.foldlWithKey' ins m2 m1 where combine f1 f2 r = f1 r ++ f2 r ins m k v = M.insertWith combine k v m ------------------------------------------------------------------------------ ruleToSet :: Rule -> RuleSet ruleToSet (Rule nm f) = RuleSet $ M.singleton nm f ------------------------------------------------------------------------------ rulesToSet :: [Rule] -> RuleSet rulesToSet = foldl' mappend (RuleSet M.empty) . map ruleToSet snap-0.14.0.6/src/Control/Access/RoleBased/Internal/Types.hs0000644000000000000000000000250412552604453021562 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Control.Access.RoleBased.Internal.Types ( module Control.Access.RoleBased.Internal.Role , module Control.Access.RoleBased.Internal.Rule , RoleMonad(..) , RuleChecker(..) ) where ------------------------------------------------------------------------------ import Control.Applicative import Control.Monad.Reader import Control.Monad.Logic ------------------------------------------------------------------------------ import Control.Access.RoleBased.Internal.Role import Control.Access.RoleBased.Internal.Rule ------------------------------------------------------------------------------ -- TODO: should the monads be transformers here? If they were, you could check -- more complex predicates here ------------------------------------------------------------------------------ newtype RoleMonad a = RoleMonad { _unRC :: Logic a } deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic) ------------------------------------------------------------------------------ newtype RuleChecker a = RuleChecker (ReaderT (RoleMonad Role) RoleMonad a) deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic) snap-0.14.0.6/src/Snap/0000755000000000000000000000000012552604453012565 5ustar0000000000000000snap-0.14.0.6/src/Snap/Snaplet.hs0000644000000000000000000002550112552604453014532 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-| Snaplets allow you to build web applications out of composable parts. This allows you to build self-contained units and glue them together to make your overall application. A snaplet has a few moving parts, some user-defined and some provided by the snaplet API: * each snaplet has its own configuration given to it at startup. * each snaplet is given its own directory on the filesystem, from which it reads its configuration and in which it can store files. * each snaplet comes with an 'Initializer' which defines how to create an instance of the Snaplet at startup. The initializer decides how to interpret the snaplet configuration, which URLs to handle (and how), sets up the initial snaplet state, tells the snaplet runtime system how to clean the snaplet up, etc. * each snaplet contains some user-defined in-memory state; for instance, a snaplet that talks to a database might contain a reference to a connection pool. The snaplet state is an ordinary Haskell record, with a datatype defined by the snaplet author. The initial state record is created during initialization and is available to snaplet 'Handler's when serving HTTP requests. NOTE: This documentation is written as a prose tutorial of the snaplets API. Don't be scared by the fact that it's auto-generated and is filled with type signatures. Just keep reading. -} module Snap.Snaplet ( -- * Snaplet -- $snapletDoc Snaplet , SnapletConfig -- * Lenses -- $lenses -- * Snaplet Helper Functions -- $snapletHelpers , snapletConfig , snapletValue , subSnaplet -- * MonadSnaplet -- $monadSnaplet , MonadSnaplet(..) , getSnapletAncestry , getSnapletFilePath , getSnapletName , getSnapletDescription , getSnapletUserConfig , getSnapletRootURL , snapletURL , getRoutePattern , setRoutePattern -- * Snaplet state manipulation -- $snapletState , getSnapletState , putSnapletState , modifySnapletState , getsSnapletState -- , wrap -- , wrapTop -- * Initializer -- $initializer , Initializer , SnapletInit , makeSnaplet , nestSnaplet , embedSnaplet , nameSnaplet , onUnload , addPostInitHook , addPostInitHookBase , printInfo , getRoutes , getEnvironment -- * Routes -- $routes , addRoutes , wrapSite -- * Handlers , Handler , failIfNotLocal , reloadSite , modifyMaster , bracketHandler -- * Serving Applications , runSnaplet , combineConfig , serveSnaplet , loadAppConfig -- * Snaplet Lenses , SnapletLens ) where import Snap.Snaplet.Internal.Initializer import Snap.Snaplet.Internal.Types -- $snapletDoc -- The heart of the snaplets infrastructure is state management. (Note: when -- we say \"state\" here, we mean in-memory Haskell objects, not external data -- storage or databases; how you deal with persisted data is up to you.) Most -- nontrivial pieces of a web application need some kind of runtime state or -- environment data. The datatype we use to handle this is called 'Snaplet': -- $snapletHelpers -- -- Your web application will itself get wrapped in a 'Snaplet', and the -- top-level user state of your application (which will likely contain other -- snaplets nested inside it) will look something like this: -- -- > data App = App -- > { _foo :: Snaplet Foo -- > , _bar :: Snaplet Bar -- > , _someNonSnapletData :: String -- > } -- -- Every web application using snaplets has a top-most user state which -- contains all of the application state; we call this state the \"base\" -- state. -- -- We export several helper lenses for working with Snaplet types. -- $lenses -- In the example above, the @Foo@ snaplet has to be written to work with any -- base state (otherwise it wouldn't be reusable!), but functions written to -- work with the @Foo@ snaplet want to be able to modify the @Foo@ record -- /within the context/ of the base state. Given that Haskell datatypes are -- pure, how do you allow for this? -- -- Our solution is to use /lenses/, as defined in Edward Kmett's @lens@ -- library (). A lens, notated -- as follows: -- -- > SimpleLens a b -- -- is conceptually a \"getter\" and a \"setter\" rolled up into one. The -- @lens@ library provides the following functions: -- -- > view :: (SimpleLens a b) -> a -> b -- > set :: (SimpleLens a b) -> b -> a -> a -- > over :: (SimpleLens a b) -> (b -> b) -> a -> a -- -- which allow you to get, set, and modify a value of type @b@ within the -- context of type @a@. The @lens@ package comes with a Template Haskell -- function called 'makeLenses', which auto-magically defines a lens for every -- record field having a name beginning with an underscore. In the @App@ -- example above, adding the declaration: -- -- > makeLenses ''App -- -- would define lenses: -- -- > foo :: SimpleLens App (Snaplet Foo) -- > bar :: SimpleLens App (Snaplet Bar) -- > someNonSnapletData :: SimpleLens App String -- -- The coolest thing about @lens@ lenses is that they /compose/ using the -- @(.)@ operator. If the @Foo@ type had a field of type @Quux@ within it with -- a lens @quux :: SimpleLens Foo Quux@, then you could create a lens of type -- @SimpleLens App Quux@ by composition: -- -- > import Control.Lens -- > -- > data Foo = Foo { _quux :: Quux } -- > makeLenses ''Foo -- > -- > -- snapletValue is defined in the framework: -- > snapletValue :: SimpleLens (Snaplet a) a -- > -- > appQuuxLens :: SimpleLens App Quux -- > appQuuxLens = foo . snapletValue . quux -- -- Lens composition is very similar to function composition except it works in -- the opposite direction (think Java-style System.out.println ordering) and -- it gives you a composed getter and setter at the same time. -- $monadSnaplet -- The primary abstraction in the snaplet infrastructure is a combination of -- the reader and state monads. The state monad holds the top level -- application data type (from now on referred to as the base state). The -- reader monad holds a lens from the base state to the current snaplet's -- state. This allows quux snaplet functions to access and modify the Quux -- data structure without knowing anything about the App or Foo data -- structures. It also lets other snaplets call functions from the quux -- snaplet if they have the quux snaplet's lens @SimpleLens App (Snaplet Quux)@. -- We can view our application as a tree of snaplets and other pieces of data. -- The lenses are like pointers to nodes of the tree. If you have a pointer to -- a node, you can access the node and all of its children without knowing -- anything about the rest of the tree. -- -- Several monads use this infrastructure. These monads need at least three -- type parameters. Two for the lens type, and the standard \'a\' denoting the -- monad return value. You will usually see this written in type signatures as -- \"m b v a\" or some variation. The \'m\' is the type variable of the -- MonadSnaplet type class. \'b\' is the base state, and \'v\' is the state of -- the current \"view\" snaplet (or simply, current state). -- -- The MonadSnaplet type class distills the essence of the operations used -- with this pattern. Its functions define fundamental methods for navigating -- snaplet trees. -- $snapletState -- MonadSnaplet instances will typically have @MonadState v@ instances. We -- provide the following convenience functions which give the equivalent to -- @MonadState (Snaplet v)@ for the less common cases where you need to work -- with the Snaplet wrapper. -- $initializer -- The Initializer monad is where your application's initialization happens. -- Initializers are run at startup and any time a site reload is triggered. -- The Initializer's job is to construct a snaplet's routes and initial state, -- set up filesystem data, read config files, etc. -- -- In order to initialize its state, a snaplet needs to initialize all the -- @Snaplet a@ state for each of its subsnaplets. The only way to construct -- a @Snaplet a@ type is by calling 'nestSnaplet' or 'embedSnaplet' from -- within an initializer. -- $writingSnaplets -- When writing a snaplet, you must define an initializer function. The -- initializer function for the Foo snaplet (where Foo is the snaplet's -- state type) must have a return type of @Initializer b Foo Foo@. -- To create an initializer like this, you have to use the 'makeSnaplet' -- function. It takes care of the necessary internal bookkeeping needed when -- initializing a new snaplet. Haskell's strong type system allows us to -- ensure that calling 'makeSnaplet' is the only way you can construct a -- Snaplet type. -- $routes -- Snaplet initializers are also responsible for setting up any routes defined -- by the snaplet. To do that you'll usually use either 'addRoutes' or -- 'wrapSite'. {- /FIXME/: finish this section Discuss: * lenses and how snaplet apps are built out of parts. * the initializer type, and what you can do with it * layout of snaplets on disk, and how on-disk stuff can be auto-populated from the cabal data directory * the handler type, and what you can do with it {FIXME: strike/rewrite these sentences. Components that do not need any kind of state or environment are probably more appropriate as a standalone library than as a snaplet. We start our application by defining a data structure to hold the state. This data structure includes the state of any snaplets (wrapped in a Snaplet) we want to use as well as any other state we might want.} > module MyApp where > import Control.Lens > import Snap.Snaplet > import Snap.Snaplet.Heist > > data App = App > { _heist :: Snaplet (Heist App) > , _foo :: Snaplet Foo > , _bar :: Snaplet Bar > , _companyName :: String > } > > makeLenses ''App The next thing we need to do is define an initializer. > app :: Initializer App App App > app = do > hs <- nestSnaplet "heist" $ heistInit "templates" > fs <- nestSnaplet "foo" $ fooInit heist > bs <- nestSnaplet "" $ nameSnaplet "baz" $ barInit heist > addRoutes [ ("/hello", writeText "hello world") > ] > wrapSite (<|> with heist heistServe) > return $ App hs fs bs "fooCorp" Then we define a simple main to run the application. > main = serveSnaplet defaultConfig app Snaplet filesystem directory structure: > snaplet > |-- snaplet.cabal > |-- log/ > |-- src/ > ------------------------ > |-- db.cfg > |-- snaplet.cfg > |-- public/ > |-- stylesheets/ > |-- images/ > |-- js/ > |-- snaplets > |-- subsnaplet1/ > |-- subsnaplet2/ > |-- templates/ -} snap-0.14.0.6/src/Snap/Starter.hs0000644000000000000000000001106412552604453014547 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where ------------------------------------------------------------------------------ import Data.Char import Data.List import qualified Data.ByteString.Char8 as S import qualified Data.Text as T import Snap.Http.Server (snapServerVersion) import System.Directory import System.Environment import System.Exit import System.Console.GetOpt import System.FilePath ------------------------------------------------------------------------------ import Snap.StarterTH ------------------------------------------------------------------------------ -- Creates a value tDir :: ([String], [(String, String)]) buildData "tDirBareBones" "barebones" buildData "tDirDefault" "default" buildData "tDirTutorial" "tutorial" ------------------------------------------------------------------------------ usage :: String usage = unlines [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter" , "" , "Usage:" , "" , " snap " , "" , " can be one of:" , " init - create a new project directory structure in the " ++ "current directory" , "" , " Note: you can use --help after any of the above actions to get help " , " on that action" ] ------------------------------------------------------------------------------ initUsage :: String initUsage = unlines [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter" , "" , "Usage:" , "" , " snap init [type]" , "" , " [type] can be one of:" , " default - A default project using snaplets and heist" , " barebones - A barebones project with minimal dependencies" , " tutorial - The literate Haskell tutorial project" , "" , " If [type] is omitted, the default project is generated." ] ------------------------------------------------------------------------------ printUsage :: [String] -> IO () printUsage ("init":_) = putStrLn initUsage printUsage _ = putStrLn usage ------------------------------------------------------------------------------ -- Only one option for now data Option = Help deriving (Show, Eq) ------------------------------------------------------------------------------ setup :: String -> ([FilePath], [(String, String)]) -> IO () setup projName tDir = do mapM createDirectory (fst tDir) mapM_ write (snd tDir) where -------------------------------------------------------------------------- write (f,c) = if isSuffixOf "foo.cabal" f then writeFile (projName ++ ".cabal") (insertProjName $ T.pack c) else writeFile f c -------------------------------------------------------------------------- isNameChar c = isAlphaNum c || c == '-' -------------------------------------------------------------------------- insertProjName c = T.unpack $ T.replace (T.pack "projname") (T.pack $ filter isNameChar projName) c ------------------------------------------------------------------------------ initProject :: [String] -> IO () initProject args = do case getOpt Permute options args of (flags, other, []) | Help `elem` flags -> printUsage other >> exitFailure | otherwise -> go other (_, other, errs) -> do putStrLn $ concat errs printUsage other exitFailure where -------------------------------------------------------------------------- options = [ Option ['h'] ["help"] (NoArg Help) "Print this message" ] -------------------------------------------------------------------------- go ("init":rest) = init' rest go _ = do putStrLn "Error: Invalid action!" putStrLn usage exitFailure -------------------------------------------------------------------------- init' args' = do cur <- getCurrentDirectory let dirs = splitDirectories cur projName = last dirs setup' = setup projName case args' of [] -> setup' tDirDefault ["barebones"] -> setup' tDirBareBones ["default"] -> setup' tDirDefault ["tutorial"] -> setup' tDirTutorial _ -> do putStrLn initUsage exitFailure ------------------------------------------------------------------------------ main :: IO () main = do args <- getArgs initProject args snap-0.14.0.6/src/Snap/StarterTH.hs0000644000000000000000000000404512552604453015004 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Snap.StarterTH where ------------------------------------------------------------------------------ import qualified Data.Foldable as F import Data.List import Language.Haskell.TH import Language.Haskell.TH.Syntax import System.Directory.Tree import System.FilePath ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Convenience types type FileData = (String, String) type DirData = FilePath ------------------------------------------------------------------------------ -- Gets all the directories in a DirTree -- getDirs :: [FilePath] -> DirTree a -> [FilePath] getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) : concatMap (getDirs (n:prefix)) c getDirs _ (File _ _) = [] getDirs _ (Failed _ _) = [] ------------------------------------------------------------------------------ -- Reads a directory and returns a tuple of the list of all directories -- encountered and a list of filenames and content strings. -- readTree :: FilePath -> IO ([DirData], [FileData]) readTree dir = do d <- readDirectory $ dir "." let ps = zipPaths $ "" :/ (free d) fd = F.foldr (:) [] ps dirs = getDirs [] $ free d return (drop 1 dirs, fd) ------------------------------------------------------------------------------ -- Calls readTree and returns its value in a quasiquote. -- dirQ :: FilePath -> Q Exp dirQ tplDir = do d <- runIO . readTree $ "project_template" tplDir lift d ------------------------------------------------------------------------------ -- Creates a declaration assigning the specified name the value returned by -- dirQ. -- buildData :: String -> FilePath -> Q [Dec] buildData dirName tplDir = do let dir = mkName dirName typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |] v <- valD (varP dir) (normalB $ dirQ tplDir) [] return [typeSig, v] snap-0.14.0.6/src/Snap/Snaplet/0000755000000000000000000000000012552604453014173 5ustar0000000000000000snap-0.14.0.6/src/Snap/Snaplet/Auth.hs0000644000000000000000000000330312552604453015427 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ -- | -- -- This module contains all the central authentication functionality. -- -- It exports a number of high-level functions to be used directly in your -- application handlers. -- -- We also export a number of mid-level functions that should be helpful when -- you are integrating with another way of confirming the authentication of -- login requests. -- module Snap.Snaplet.Auth ( -- * Higher Level Handler Functions createUser , usernameExists , saveUser , destroyUser , loginByUsername , loginByRememberToken , forceLogin , logout , currentUser , isLoggedIn -- * Lower Level Functions , markAuthSuccess , markAuthFail , checkPasswordAndLogin -- * Types , AuthManager(..) , IAuthBackend(..) , AuthSettings(..) , defAuthSettings , AuthUser(..) , defAuthUser , UserId(..) , Password(..) , AuthFailure(..) , Role(..) -- * Other Utilities , authSettingsFromConfig , withBackend , encryptPassword , checkPassword , authenticatePassword , setPassword , encrypt , verify -- * Handlers , registerUser , loginUser , logoutUser , requireUser , setPasswordResetToken , clearPasswordResetToken -- * Splice helpers , addAuthSplices , compiledAuthSplices , userCSplices , userISplices , ifLoggedIn , ifLoggedOut , loggedInUser ) where ------------------------------------------------------------------------------ import Snap.Snaplet.Auth.AuthManager import Snap.Snaplet.Auth.Handlers import Snap.Snaplet.Auth.SpliceHelpers import Snap.Snaplet.Auth.Types snap-0.14.0.6/src/Snap/Snaplet/Config.hs0000644000000000000000000000500512552604453015734 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} module Snap.Snaplet.Config where import Data.Function import Data.Maybe import Data.Monoid import Data.Typeable import Snap.Core import Snap.Http.Server.Config import System.Console.GetOpt ------------------------------------------------------------------------------ -- | AppConfig contains the config options for command line arguments in -- snaplet-based apps. newtype AppConfig = AppConfig { appEnvironment :: Maybe String } #if MIN_VERSION_base(4,7,0) deriving Typeable #else ------------------------------------------------------------------------------ -- | AppConfig has a manual instance of Typeable due to limitations in the -- tools available before GHC 7.4, and the need to make dynamic loading -- tractable. When support for earlier versions of GHC is dropped, the -- dynamic loader package can be updated so that manual Typeable instances -- are no longer needed. appConfigTyCon :: TyCon appConfigTyCon = mkTyCon "Snap.Snaplet.Config.AppConfig" {-# NOINLINE appConfigTyCon #-} instance Typeable AppConfig where typeOf _ = mkTyConApp appConfigTyCon [] #endif ------------------------------------------------------------------------------ instance Monoid AppConfig where mempty = AppConfig Nothing mappend a b = AppConfig { appEnvironment = ov appEnvironment a b } where ov f x y = getLast $! (mappend `on` (Last . f)) x y ------------------------------------------------------------------------------ -- | Command line options for snaplet applications. appOpts :: AppConfig -> [OptDescr (Maybe (Config m AppConfig))] appOpts defaults = map (fmapOpt $ fmap (flip setOther mempty)) [ Option ['e'] ["environment"] (ReqArg setter "ENVIRONMENT") $ "runtime environment to use" ++ defaultC appEnvironment ] where setter s = Just $ mempty { appEnvironment = Just s} defaultC f = maybe "" ((", default " ++) . show) $ f defaults ------------------------------------------------------------------------------ -- | Calls snap-server's extendedCommandLineConfig to add snaplet options to -- the built-in server command line options. commandLineAppConfig :: MonadSnap m => Config m AppConfig -> IO (Config m AppConfig) commandLineAppConfig defaults = extendedCommandLineConfig (appOpts appDefaults ++ optDescrs defaults) mappend defaults where appDefaults = fromMaybe mempty $ getOther defaults snap-0.14.0.6/src/Snap/Snaplet/Heist.hs0000644000000000000000000003151712552604453015612 0ustar0000000000000000------------------------------------------------------------------------------ -- | The Heist snaplet makes it easy to add Heist to your application and use -- it in other snaplets. -- module Snap.Snaplet.Heist ( -- * Heist and its type class Heist , HasHeist(..) -- * Initializer Functions -- $initializerSection , heistInit , heistInit' , Unclassed.heistReloader , Unclassed.setInterpreted , Unclassed.getCurHeistConfig , addTemplates , addTemplatesAt , Unclassed.addConfig , getHeistState , modifyHeistState , withHeistState -- * Handler Functions -- $handlerSection , gRender , gRenderAs , gHeistServe , gHeistServeSingle , chooseMode , cRender , cRenderAs , cHeistServe , cHeistServeSingle , render , renderAs , heistServe , heistServeSingle , heistLocal , withSplices , renderWithSplices -- * Writing Splices -- $spliceSection , Unclassed.SnapletHeist , Unclassed.SnapletCSplice , Unclassed.SnapletISplice , clearHeistCache ) where ------------------------------------------------------------------------------ import Prelude hiding (id, (.)) import Control.Monad.State import Data.ByteString (ByteString) import Heist ------------------------------------------------------------------------------ import Snap.Snaplet import Snap.Snaplet.Heist.Internal import qualified Snap.Snaplet.HeistNoClass as Unclassed import Snap.Snaplet.HeistNoClass ( heistInit , heistInit' , clearHeistCache ) ------------------------------------------------------------------------------ -- | A single snaplet should never need more than one instance of Heist as a -- subsnaplet. This type class allows you to make it easy for other snaplets -- to get the lens that identifies the heist snaplet. Here's an example of -- how the heist snaplet might be declared: -- -- > data App = App { _heist :: Snaplet (Heist App) } -- > makeLenses ''App -- > -- > instance HasHeist App where heistLens = subSnaplet heist -- > -- > appInit = makeSnaplet "app" "" Nothing $ do -- > h <- nestSnaplet "heist" heist $ heistInit "templates" -- > addConfig h heistConfigWithMyAppSplices -- > return $ App h class HasHeist b where -- | A lens to the Heist snaplet. The b parameter to Heist will -- typically be the base state of your application. heistLens :: SnapletLens (Snaplet b) (Heist b) -- $initializerSection -- This section contains functions for use in setting up your Heist state -- during initialization. ------------------------------------------------------------------------------ -- | Adds templates to the Heist HeistState. Other snaplets should use -- this function to add their own templates. The templates are automatically -- read from the templates directory in the current snaplet's filesystem root. addTemplates :: HasHeist b => Snaplet (Heist b) -> ByteString -- ^ The url prefix for the template routes -> Initializer b v () addTemplates h pfx = withTop' heistLens (Unclassed.addTemplates h pfx) ------------------------------------------------------------------------------ -- | Adds templates to the Heist HeistState, and lets you specify where -- they are found in the filesystem. Note that the path to the template -- directory is an absolute path. This allows you more flexibility in where -- your templates are located, but means that you have to explicitly call -- getSnapletFilePath if you want your snaplet to use templates within its -- normal directory structure. addTemplatesAt :: HasHeist b => Snaplet (Heist b) -> ByteString -- ^ URL prefix for template routes -> FilePath -- ^ Path to templates -> Initializer b v () addTemplatesAt h pfx p = withTop' heistLens (Unclassed.addTemplatesAt h pfx p) ------------------------------------------------------------------------------ -- | More general function allowing arbitrary HeistState modification. getHeistState :: (HasHeist b) => Handler b v (HeistState (Handler b b)) getHeistState = Unclassed.getHeistState heistLens ------------------------------------------------------------------------------ -- | More general function allowing arbitrary HeistState modification. modifyHeistState :: (HasHeist b) => (HeistState (Handler b b) -> HeistState (Handler b b)) -- ^ HeistState modifying function -> Initializer b v () modifyHeistState = Unclassed.modifyHeistState' heistLens ------------------------------------------------------------------------------ -- | Runs a function on with the Heist snaplet's 'HeistState'. withHeistState :: (HasHeist b) => (HeistState (Handler b b) -> a) -- ^ HeistState function to run -> Handler b v a withHeistState = Unclassed.withHeistState' heistLens -- $handlerSection -- This section contains functions in the 'Handler' monad that you'll use in -- processing requests. Functions beginning with a 'g' prefix use generic -- rendering that checks the preferred rendering mode and chooses -- appropriately. Functions beginning with a 'c' prefix use compiled template -- rendering. The other functions use the older interpreted rendering. -- Interpreted splices added with addConfig will only work if you use -- interpreted rendering. -- -- The generic functions are useful if you are writing general snaplets that -- use heist, but need to work for applications that use either interpreted -- or compiled mode. ------------------------------------------------------------------------------ -- | Generic version of 'render'/'cRender'. gRender :: HasHeist b => ByteString -- ^ Template name -> Handler b v () gRender t = withTop' heistLens (Unclassed.gRender t) ------------------------------------------------------------------------------ -- | Generic version of 'renderAs'/'cRenderAs'. gRenderAs :: HasHeist b => ByteString -- ^ Content type to render with -> ByteString -- ^ Template name -> Handler b v () gRenderAs ct t = withTop' heistLens (Unclassed.gRenderAs ct t) ------------------------------------------------------------------------------ -- | Generic version of 'heistServe'/'cHeistServe'. gHeistServe :: HasHeist b => Handler b v () gHeistServe = withTop' heistLens Unclassed.gHeistServe ------------------------------------------------------------------------------ -- | Generic version of 'heistServeSingle'/'cHeistServeSingle'. gHeistServeSingle :: HasHeist b => ByteString -- ^ Template name -> Handler b v () gHeistServeSingle t = withTop' heistLens (Unclassed.gHeistServeSingle t) ------------------------------------------------------------------------------ -- | Chooses between a compiled action and an interpreted action based on the -- configured default. chooseMode :: HasHeist b => Handler b v a -- ^ A compiled action -> Handler b v a -- ^ An interpreted action -> Handler b v a chooseMode cAction iAction = do mode <- withTop' heistLens $ gets _defMode case mode of Unclassed.Compiled -> cAction Unclassed.Interpreted -> iAction ------------------------------------------------------------------------------ -- | Renders a compiled template as text\/html. If the given template is not -- found, this returns 'empty'. cRender :: HasHeist b => ByteString -- ^ Template name -> Handler b v () cRender t = withTop' heistLens (Unclassed.cRender t) ------------------------------------------------------------------------------ -- | Renders a compiled template as the given content type. If the given -- template is not found, this returns 'empty'. cRenderAs :: HasHeist b => ByteString -- ^ Content type to render with -> ByteString -- ^ Template name -> Handler b v () cRenderAs ct t = withTop' heistLens (Unclassed.cRenderAs ct t) ------------------------------------------------------------------------------ -- | A compiled version of 'heistServe'. cHeistServe :: HasHeist b => Handler b v () cHeistServe = withTop' heistLens Unclassed.cHeistServe ------------------------------------------------------------------------------ -- | Analogous to 'fileServeSingle'. If the given template is not found, -- this throws an error. cHeistServeSingle :: HasHeist b => ByteString -- ^ Template name -> Handler b v () cHeistServeSingle t = withTop' heistLens (Unclassed.cHeistServeSingle t) ------------------------------------------------------------------------------ -- | Renders a template as text\/html. If the given template is not found, -- this returns 'empty'. render :: HasHeist b => ByteString -- ^ Template name -> Handler b v () render t = withTop' heistLens (Unclassed.render t) ------------------------------------------------------------------------------ -- | Renders a template as the given content type. If the given template -- is not found, this returns 'empty'. renderAs :: HasHeist b => ByteString -- ^ Content type to render with -> ByteString -- ^ Template name -> Handler b v () renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t) ------------------------------------------------------------------------------ -- | A handler that serves all the templates (similar to 'serveDirectory'). -- If the template specified in the request path is not found, it returns -- 'empty'. Also, this function does not serve any templates beginning with -- an underscore. This gives you a way to prevent some templates from being -- served. For example, you might have a template that contains only the -- navbar of your pages, and you probably wouldn't want that template to be -- visible to the user as a standalone template. So if you put it in a file -- called \"_nav.tpl\", this function won't serve it. heistServe :: HasHeist b => Handler b v () heistServe = withTop' heistLens Unclassed.heistServe ------------------------------------------------------------------------------ -- | Handler for serving a single template (similar to 'fileServeSingle'). If -- the given template is not found, this throws an error. heistServeSingle :: HasHeist b => ByteString -- ^ Template name -> Handler b v () heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t) ------------------------------------------------------------------------------ -- | Renders a template with a given set of splices. This is syntax sugar for -- a common combination of heistLocal, bindSplices, and render. renderWithSplices :: HasHeist b => ByteString -- ^ Template name -> Splices (Unclassed.SnapletISplice b) -- ^ Splices to bind -> Handler b v () renderWithSplices = Unclassed.renderWithSplices' heistLens ------------------------------------------------------------------------------ -- | Runs an action with additional splices bound into the Heist -- 'HeistState'. withSplices :: HasHeist b => Splices (Unclassed.SnapletISplice b) -- ^ Splices to bind -> Handler b v a -- ^ Handler to run -> Handler b v a withSplices = Unclassed.withSplices' heistLens ------------------------------------------------------------------------------ -- | Runs a handler with a modified 'HeistState'. You might want to use -- this if you had a set of splices which were customised for a specific -- action. To do that you would do: -- -- > heistLocal (bindSplices mySplices) handlerThatNeedsSplices heistLocal :: HasHeist b => (HeistState (Handler b b) -> HeistState (Handler b b)) -- ^ HeistState modifying function -> Handler b v a -- ^ Handler to run -> Handler b v a heistLocal = Unclassed.heistLocal' heistLens -- $spliceSection -- The type signature for SnapletHeist uses @(Handler b b)@ as the Heist -- snaplet's runtime monad. This means that your splices must use the -- top-level snaplet's @Handler b b@ monad. The reasons for this are beyond -- the scope of this discussion, but the result is that 'lift' inside a splice -- only works with @Handler b b@ actions. When you're writing your own -- snaplets using some snaplet-specific monad @Handler b v@ you still have to -- use @Handler b b@ for your splices. If the splices need any of the context -- provided by the @v@, you must pass it in as a parameter to the splice -- function. snap-0.14.0.6/src/Snap/Snaplet/HeistNoClass.hs0000644000000000000000000004144312552604453017074 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} {-| This module implements the Heist snaplet without using type classes. It is provided mainly as an example of how snaplets can be written with and without a type class for convenience. -} module Snap.Snaplet.HeistNoClass ( Heist , DefaultMode(..) , heistInit , heistInit' , heistReloader , setInterpreted , getCurHeistConfig , clearHeistCache , addTemplates , addTemplatesAt , getHeistState , modifyHeistState , modifyHeistState' , withHeistState , withHeistState' , gRender , gRenderAs , gHeistServe , gHeistServeSingle , chooseMode , addConfig , cRender , cRenderAs , cHeistServe , cHeistServeSingle , render , renderAs , heistServe , heistServeSingle , heistLocal , withSplices , renderWithSplices , heistLocal' , withSplices' , renderWithSplices' , SnapletHeist , SnapletISplice , SnapletCSplice ) where import Prelude hiding ((.), id) import Control.Applicative import Control.Category import Control.Lens import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Either import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.DList (DList) import qualified Data.HashMap.Strict as Map import Data.IORef import Data.Maybe import Data.Monoid import qualified Data.Text as T import Data.Text.Encoding import System.FilePath.Posix import Heist import qualified Heist.Compiled as C import qualified Heist.Interpreted as I import Heist.Splices.Cache import Snap.Snaplet import Snap.Snaplet.Heist.Internal import Snap.Core import Snap.Util.FileServe ------------------------------------------------------------------------------ changeState :: (HeistState (Handler a a) -> HeistState (Handler a a)) -> Heist a -> Heist a changeState _ (Configuring _) = error "changeState: HeistState has not been initialized" changeState f (Running hc hs cts dm) = Running hc (f hs) cts dm ------------------------------------------------------------------------------ -- | Clears data stored by the cache tag. The cache tag automatically reloads -- its data when the specified TTL expires, but sometimes you may want to -- trigger a manual reload. This function lets you do that. clearHeistCache :: Heist b -> IO () clearHeistCache = clearCacheTagState . _heistCTS ----------------------------- -- SnapletSplice functions -- ----------------------------- ------------------------------------------------------------------------------ -- | This instance is here because we don't want the heist package to depend -- on anything from snap packages. instance MonadSnap m => MonadSnap (HeistT n m) where liftSnap = lift . liftSnap type SnapletHeist b m a = HeistT (Handler b b) m a type SnapletCSplice b = SnapletHeist b IO (DList (Chunk (Handler b b))) type SnapletISplice b = SnapletHeist b (Handler b b) Template --------------------------- -- Initializer functions -- --------------------------- ------------------------------------------------------------------------------ -- | The 'Initializer' for 'Heist'. This function is a convenience wrapper -- around `heistInit'` that uses defaultHeistState and sets up routes for all -- the templates. It sets up a \"heistReload\" route that reloads the heist -- templates when you request it from localhost. heistInit :: FilePath -- ^ Path to templates -> SnapletInit b (Heist b) heistInit = gHeistInit heistServe ------------------------------------------------------------------------------ -- | A lower level 'Initializer' for 'Heist'. This initializer requires you -- to specify the initial HeistConfig. It also does not add any routes for -- templates, allowing you complete control over which templates get routed. heistInit' :: FilePath -- ^ Path to templates -> HeistConfig (Handler b b) -- ^ Initial HeistConfig -> SnapletInit b (Heist b) heistInit' templateDir initialConfig = makeSnaplet "heist" "" Nothing $ heistInitWorker templateDir initialConfig ------------------------------------------------------------------------------ -- | Sets the snaplet to default to interpreted mode. Initially, the -- initializer sets the value to compiled mode. This function allows you to -- override that setting. Note that this is just a default. It only has an -- effect if you use one of the generic functions: 'gRender', 'gRenderAs', -- 'gHeistServe', or 'gHeistServeSingle'. If you call the non-generic -- versions directly, then this value will not be checked and you will get the -- mode implemented by the function you called. setInterpreted :: Snaplet (Heist b) -> Initializer b v () setInterpreted h = liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) (\(hc,_) -> ((hc,Interpreted),())) ------------------------------------------------------------------------------ -- | Adds templates to the Heist HeistConfig. Other snaplets should use -- this function to add their own templates. The templates are automatically -- read from the templates directory in the current snaplet's filesystem root. addTemplates :: Snaplet (Heist b) -> ByteString -- ^ The url prefix for the template routes -> Initializer b (Heist b) () addTemplates h urlPrefix = do snapletPath <- getSnapletFilePath addTemplatesAt h urlPrefix (snapletPath "templates") ------------------------------------------------------------------------------ -- | Adds templates to the Heist HeistConfig, and lets you specify where -- they are found in the filesystem. Note that the path to the template -- directory is an absolute path. This allows you more flexibility in where -- your templates are located, but means that you have to explicitly call -- getSnapletFilePath if you want your snaplet to use templates within its -- normal directory structure. addTemplatesAt :: Snaplet (Heist b) -> ByteString -- ^ URL prefix for template routes -> FilePath -- ^ Path to templates -> Initializer b (Heist b) () addTemplatesAt h urlPrefix templateDir = do rootUrl <- getSnapletRootURL let fullPrefix = (T.unpack $ decodeUtf8 rootUrl) (T.unpack $ decodeUtf8 urlPrefix) addPrefix = addTemplatePathPrefix (encodeUtf8 $ T.pack fullPrefix) ts <- liftIO $ runEitherT (loadTemplates templateDir) >>= either (error . concat) return printInfo $ T.pack $ unwords [ "...adding" , (show $ Map.size ts) , "templates from" , templateDir , "with route prefix" , fullPrefix ++ "/" ] let locations = [liftM addPrefix $ loadTemplates templateDir] add (hc, dm) = ((over hcTemplateLocations (mappend locations) hc, dm), ()) liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) add getCurHeistConfig :: Snaplet (Heist b) -> Initializer b v (HeistConfig (Handler b b)) getCurHeistConfig h = case view snapletValue h of Configuring ref -> do (hc, _) <- liftIO $ readIORef ref return hc Running _ _ _ _ -> error "Can't get HeistConfig after heist is initialized." ------------------------------------------------------------------------------ getHeistState :: SnapletLens (Snaplet b) (Heist b) -> Handler b v (HeistState (Handler b b)) getHeistState heist = withTop' heist $ gets _heistState ------------------------------------------------------------------------------ modifyHeistState' :: SnapletLens (Snaplet b) (Heist b) -> (HeistState (Handler b b) -> HeistState (Handler b b)) -> Initializer b v () modifyHeistState' heist f = do withTop' heist $ addPostInitHook $ return . changeState f ------------------------------------------------------------------------------ modifyHeistState :: SnapletLens b (Heist b) -> (HeistState (Handler b b) -> HeistState (Handler b b)) -> Initializer b v () modifyHeistState heist f = modifyHeistState' (subSnaplet heist) f ------------------------------------------------------------------------------ withHeistState' :: SnapletLens (Snaplet b) (Heist b) -> (HeistState (Handler b b) -> a) -> Handler b v a withHeistState' heist f = do hs <- withTop' heist $ gets _heistState return $ f hs ------------------------------------------------------------------------------ withHeistState :: SnapletLens b (Heist b) -> (HeistState (Handler b b) -> a) -> Handler b v a withHeistState heist f = withHeistState' (subSnaplet heist) f ------------------------------------------------------------------------------ -- | Adds more HeistConfig data using mappend with whatever is currently -- there. This is the preferred method for adding all four kinds of splices -- as well as new templates. addConfig :: Snaplet (Heist b) -> SpliceConfig (Handler b b) -> Initializer b v () addConfig h sc = case view snapletValue h of Configuring ref -> liftIO $ atomicModifyIORef ref add Running _ _ _ _ -> do printInfo "finalLoadHook called while running" error "this shouldn't happen" where add (hc, dm) = ((over hcSpliceConfig (`mappend` sc) hc, dm), ()) ----------------------- -- Handler functions -- ----------------------- ------------------------------------------------------------------------------ -- | Internal helper function for rendering. iRenderHelper :: Maybe MIMEType -> ByteString -> Handler b (Heist b) () iRenderHelper c t = do (Running _ hs _ _) <- get withTop' id $ I.renderTemplate hs t >>= maybe pass serve where serve (b, mime) = do modifyResponse $ setContentType $ fromMaybe mime c writeBuilder b ------------------------------------------------------------------------------ -- | Internal helper function for rendering. cRenderHelper :: Maybe MIMEType -> ByteString -> Handler b (Heist b) () cRenderHelper c t = do (Running _ hs _ _) <- get withTop' id $ maybe pass serve $ C.renderTemplate hs t where serve (b, mime) = do modifyResponse $ setContentType $ fromMaybe mime c writeBuilder =<< b ------------------------------------------------------------------------------ serveURI :: Handler b (Heist b) ByteString serveURI = do p <- getSafePath -- Allows users to prefix template filenames with an underscore to prevent -- the template from being served. if take 1 p == "_" then pass else return $ B.pack p ------------------------------------------------------------------------------ render :: ByteString -- ^ Name of the template -> Handler b (Heist b) () render t = iRenderHelper Nothing t ------------------------------------------------------------------------------ renderAs :: ByteString -- ^ Content type -> ByteString -- ^ Name of the template -> Handler b (Heist b) () renderAs ct t = iRenderHelper (Just ct) t ------------------------------------------------------------------------------ heistServe :: Handler b (Heist b) () heistServe = ifTop (render "index") <|> (render =<< serveURI) ------------------------------------------------------------------------------ heistServeSingle :: ByteString -> Handler b (Heist b) () heistServeSingle t = render t <|> error ("Template " ++ show t ++ " not found.") ------------------------------------------------------------------------------ cRender :: ByteString -- ^ Name of the template -> Handler b (Heist b) () cRender t = cRenderHelper Nothing t ------------------------------------------------------------------------------ cRenderAs :: ByteString -- ^ Content type -> ByteString -- ^ Name of the template -> Handler b (Heist b) () cRenderAs ct t = cRenderHelper (Just ct) t ------------------------------------------------------------------------------ cHeistServe :: Handler b (Heist b) () cHeistServe = ifTop (cRender "index") <|> (cRender =<< serveURI) ------------------------------------------------------------------------------ cHeistServeSingle :: ByteString -> Handler b (Heist b) () cHeistServeSingle t = cRender t <|> error ("Template " ++ show t ++ " not found.") ------------------------------------------------------------------------------ -- | Chooses between a compiled action and an interpreted action based on the -- configured default. chooseMode :: MonadState (Heist b1) m => m b -- ^ A compiled action -> m b -- ^ An interpreted action -> m b chooseMode cAction iAction = do mode <- gets _defMode case mode of Compiled -> cAction Interpreted -> iAction ------------------------------------------------------------------------------ -- | Like render/cRender, but chooses between the two appropriately based on -- the default mode. gRender :: ByteString -- ^ Name of the template -> Handler b (Heist b) () gRender t = chooseMode (cRender t) (render t) ------------------------------------------------------------------------------ -- | Like renderAs/cRenderAs, but chooses between the two appropriately based -- on the default mode. gRenderAs :: ByteString -- ^ Content type -> ByteString -- ^ Name of the template -> Handler b (Heist b) () gRenderAs ct t = chooseMode (cRenderAs ct t) (renderAs ct t) ------------------------------------------------------------------------------ -- | Like heistServe/cHeistServe, but chooses between the two appropriately -- based on the default mode. gHeistServe :: Handler b (Heist b) () gHeistServe = chooseMode cHeistServe heistServe ------------------------------------------------------------------------------ -- | Like heistServeSingle/cHeistServeSingle, but chooses between the two -- appropriately based on the default mode. gHeistServeSingle :: ByteString -> Handler b (Heist b) () gHeistServeSingle t = chooseMode (cHeistServeSingle t) (heistServeSingle t) ------------------------------------------------------------------------------ heistLocal' :: SnapletLens (Snaplet b) (Heist b) -> (HeistState (Handler b b) -> HeistState (Handler b b)) -> Handler b v a -> Handler b v a heistLocal' heist f m = do hs <- withTop' heist get withTop' heist $ modify $ changeState f res <- m withTop' heist $ put hs return res ------------------------------------------------------------------------------ heistLocal :: SnapletLens b (Heist b) -> (HeistState (Handler b b) -> HeistState (Handler b b)) -> Handler b v a -> Handler b v a heistLocal heist f m = heistLocal' (subSnaplet heist) f m ------------------------------------------------------------------------------ withSplices' :: SnapletLens (Snaplet b) (Heist b) -> Splices (SnapletISplice b) -> Handler b v a -> Handler b v a withSplices' heist splices m = do heistLocal' heist (I.bindSplices splices) m ------------------------------------------------------------------------------ withSplices :: SnapletLens b (Heist b) -> Splices (SnapletISplice b) -> Handler b v a -> Handler b v a withSplices heist splices m = withSplices' (subSnaplet heist) splices m ------------------------------------------------------------------------------ renderWithSplices' :: SnapletLens (Snaplet b) (Heist b) -> ByteString -> Splices (SnapletISplice b) -> Handler b v () renderWithSplices' heist t splices = withSplices' heist splices $ withTop' heist $ render t ------------------------------------------------------------------------------ renderWithSplices :: SnapletLens b (Heist b) -> ByteString -> Splices (SnapletISplice b) -> Handler b v () renderWithSplices heist t splices = renderWithSplices' (subSnaplet heist) t splices snap-0.14.0.6/src/Snap/Snaplet/Session.hs0000644000000000000000000000752212552604453016160 0ustar0000000000000000module Snap.Snaplet.Session ( SessionManager , withSession , commitSession , setInSession , getFromSession , deleteFromSession , csrfToken , sessionToList , resetSession , touchSession -- * Utilities Exported For Convenience , module Snap.Snaplet.Session.Common , module Snap.Snaplet.Session.SecureCookie ) where ------------------------------------------------------------------------------ import Control.Monad.State import Data.Text (Text) import Snap.Core ------------------------------------------------------------------------------ import Snap.Snaplet import Snap.Snaplet.Session.Common import Snap.Snaplet.Session.SecureCookie import Snap.Snaplet.Session.SessionManager ( ISessionManager(..), SessionManager(..) ) import qualified Snap.Snaplet.Session.SessionManager as SM ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | Wrap around a handler, committing any changes in the session at the end -- withSession :: SnapletLens b SessionManager -> Handler b v a -> Handler b v a withSession l h = do a <- h withTop l commitSession return a ------------------------------------------------------------------------------ -- | Commit changes to session within the current request cycle -- commitSession :: Handler b SessionManager () commitSession = do SessionManager b <- loadSession liftSnap $ commit b ------------------------------------------------------------------------------ -- | Set a key-value pair in the current session -- setInSession :: Text -> Text -> Handler b SessionManager () setInSession k v = do SessionManager r <- loadSession let r' = SM.insert k v r put $ SessionManager r' ------------------------------------------------------------------------------ -- | Get a key from the current session -- getFromSession :: Text -> Handler b SessionManager (Maybe Text) getFromSession k = do SessionManager r <- loadSession return $ SM.lookup k r ------------------------------------------------------------------------------ -- | Remove a key from the current session -- deleteFromSession :: Text -> Handler b SessionManager () deleteFromSession k = do SessionManager r <- loadSession let r' = SM.delete k r put $ SessionManager r' ------------------------------------------------------------------------------ -- | Returns a CSRF Token unique to the current session -- csrfToken :: Handler b SessionManager Text csrfToken = do mgr@(SessionManager r) <- loadSession put mgr return $ SM.csrf r ------------------------------------------------------------------------------ -- | Return session contents as an association list -- sessionToList :: Handler b SessionManager [(Text, Text)] sessionToList = do SessionManager r <- loadSession return $ SM.toList r ------------------------------------------------------------------------------ -- | Deletes the session cookie, effectively resetting the session -- resetSession :: Handler b SessionManager () resetSession = do SessionManager r <- loadSession r' <- liftSnap $ SM.reset r put $ SessionManager r' ------------------------------------------------------------------------------ -- | Touch the session so the timeout gets refreshed -- touchSession :: Handler b SessionManager () touchSession = do SessionManager r <- loadSession let r' = SM.touch r put $ SessionManager r' ------------------------------------------------------------------------------ -- | Load the session into the manager -- loadSession :: Handler b SessionManager SessionManager loadSession = do SessionManager r <- get r' <- liftSnap $ load r return $ SessionManager r' snap-0.14.0.6/src/Snap/Snaplet/Test.hs0000644000000000000000000001472412552604453015456 0ustar0000000000000000-- | The Snap.Snaplet.Test module contains primitives and combinators for -- testing Snaplets. module Snap.Snaplet.Test ( -- ** Testing handlers evalHandler , evalHandler' , runHandler , runHandler' , getSnaplet , closeSnaplet , InitializerState , withTemporaryFile ) where ------------------------------------------------------------------------------ import Control.Concurrent.MVar import Control.Exception.Base (finally) import qualified Control.Exception as E import Control.Monad.IO.Class import Control.Monad (join) import Data.Maybe (fromMaybe) import Data.IORef import Data.Text import System.Directory import System.IO.Error ------------------------------------------------------------------------------ import Snap.Core import Snap.Snaplet import Snap.Snaplet.Internal.Types import Snap.Test hiding (evalHandler, runHandler) import qualified Snap.Test as ST import Snap.Snaplet.Internal.Initializer ------------------------------------------------------------------------------ -- | Remove the given file before running an IO computation. Obviously it -- can be used with 'Assertion'. withTemporaryFile :: FilePath -> IO () -> IO () withTemporaryFile f = finally (removeFileMayNotExist f) ------------------------------------------------------------------------------ -- | Utility function taken from Darcs removeFileMayNotExist :: FilePath -> IO () removeFileMayNotExist f = catchNonExistence (removeFile f) () where catchNonExistence :: IO a -> a -> IO a catchNonExistence job nonexistval = E.catch job $ \e -> if isDoesNotExistError e then return nonexistval else ioError e ------------------------------------------------------------------------------ -- | Helper to keep "runHandler" and "evalHandler" DRY. execHandlerComputation :: MonadIO m => (RequestBuilder m () -> Snap v -> m a) -> Maybe String -> RequestBuilder m () -> Handler b b v -> SnapletInit b b -> m (Either Text a) execHandlerComputation f env rq h s = do app <- getSnaplet env s case app of (Left e) -> return $ Left e (Right (a, is)) -> execHandlerSnaplet a is f rq h ------------------------------------------------------------------------------ -- | Helper to allow multiple calls to "runHandler" or "evalHandler" without -- multiple initializations. execHandlerSnaplet :: MonadIO m => Snaplet b -> InitializerState b -> (RequestBuilder m () -> Snap v -> m a) -> RequestBuilder m () -> Handler b b v -> m (Either Text a) execHandlerSnaplet a is f rq h = do res <- f rq $ runPureBase h a closeSnaplet is return $ Right res ------------------------------------------------------------------------------ -- | Given a Snaplet Handler and a 'RequestBuilder' defining -- a test request, runs the Handler, producing an HTTP 'Response'. -- -- Note that the output of this function is slightly different from -- 'runHandler' defined in Snap.Test, because due to the fact running -- the initializer inside 'SnapletInit' can throw an exception. runHandler :: MonadIO m => Maybe String -> RequestBuilder m () -> Handler b b v -> SnapletInit b b -> m (Either Text Response) runHandler = execHandlerComputation ST.runHandler ------------------------------------------------------------------------------ -- | A variant of runHandler that takes the Snaplet and InitializerState as -- produced by getSnaplet, so those can be re-used across requests. It does not -- run cleanup actions, so closeSnaplet should be used when finished. runHandler' :: MonadIO m => Snaplet b -> InitializerState b -> RequestBuilder m () -> Handler b b v -> m (Either Text Response) runHandler' a is = execHandlerSnaplet a is ST.runHandler ------------------------------------------------------------------------------ -- | Given a Snaplet Handler, a 'SnapletInit' specifying the initial state, -- and a 'RequestBuilder' defining a test request, runs the handler, -- returning the monadic value it produces. -- -- Throws an exception if the 'Snap' handler early-terminates with 'finishWith' -- or 'mzero'. -- -- Note that the output of this function is slightly different from -- 'evalHandler defined in Snap.Test, because due to the fact running -- the initializer inside 'SnapletInit' can throw an exception. evalHandler :: MonadIO m => Maybe String -> RequestBuilder m () -> Handler b b a -> SnapletInit b b -> m (Either Text a) evalHandler = execHandlerComputation ST.evalHandler ------------------------------------------------------------------------------ -- | A variant of evalHandler that takes the Snaplet and InitializerState as -- produced by getSnaplet, so those can be re-used across requests. It does not -- run cleanup actions, so closeSnaplet should be used when finished. evalHandler' :: MonadIO m => Snaplet b -> InitializerState b -> RequestBuilder m () -> Handler b b a -> m (Either Text a) evalHandler' a is = execHandlerSnaplet a is ST.evalHandler ------------------------------------------------------------------------------ -- | Run the given initializer, yielding a tuple where the first element is -- a @Snaplet b@, or an error message whether the initializer threw an -- exception. This is only needed for runHandler'/evalHandler'. getSnaplet :: MonadIO m => Maybe String -> SnapletInit b b -> m (Either Text (Snaplet b, InitializerState b)) getSnaplet env (SnapletInit initializer) = liftIO $ do mvar <- newEmptyMVar let resetter f = modifyMVar_ mvar (return . f) runInitializer resetter (fromMaybe "devel" env) initializer ------------------------------------------------------------------------------ -- | Run cleanup for an initializer. Should be run after finished using the -- state that getSnaplet returned. Only needed if using getSnaplet and -- evalHandler'/runHandler'. closeSnaplet :: MonadIO m => InitializerState b -> m () closeSnaplet is = liftIO $ join (readIORef $ _cleanup is) snap-0.14.0.6/src/Snap/Snaplet/Auth/0000755000000000000000000000000012552604453015074 5ustar0000000000000000snap-0.14.0.6/src/Snap/Snaplet/Auth/AuthManager.hs0000644000000000000000000000706712552604453017636 0ustar0000000000000000------------------------------------------------------------------------------ -- | Internal module exporting AuthManager implementation. -- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Snap.Snaplet.Auth.AuthManager ( -- * AuthManager Datatype AuthManager(..) -- * Backend Typeclass , IAuthBackend(..) -- * Context-free Operations , buildAuthUser ) where ------------------------------------------------------------------------------ import Data.ByteString (ByteString) import Data.Text (Text) import Data.Time import Web.ClientSession import Snap.Snaplet import Snap.Snaplet.Session import Snap.Snaplet.Auth.Types ------------------------------------------------------------------------------ -- | Creates a new user from a username and password. -- buildAuthUser :: IAuthBackend r => r -- ^ An auth backend -> Text -- ^ Username -> ByteString -- ^ Password -> IO (Either AuthFailure AuthUser) buildAuthUser r unm pass = do now <- getCurrentTime let au = defAuthUser { userLogin = unm , userPassword = Nothing , userCreatedAt = Just now , userUpdatedAt = Just now } au' <- setPassword au pass save r au' ------------------------------------------------------------------------------ -- | All storage backends need to implement this typeclass -- class IAuthBackend r where -- | Create or update the given 'AuthUser' record. A 'userId' of Nothing -- indicates that a new user should be created, otherwise the user -- information for that userId should be updated. save :: r -> AuthUser -> IO (Either AuthFailure AuthUser) lookupByUserId :: r -> UserId -> IO (Maybe AuthUser) lookupByLogin :: r -> Text -> IO (Maybe AuthUser) lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser) destroy :: r -> AuthUser -> IO () ------------------------------------------------------------------------------ -- | Abstract data type holding all necessary information for auth operation data AuthManager b = forall r. IAuthBackend r => AuthManager { backend :: r -- ^ Storage back-end , session :: SnapletLens b SessionManager -- ^ A lens pointer to a SessionManager , activeUser :: Maybe AuthUser -- ^ A per-request logged-in user cache , minPasswdLen :: Int -- ^ Password length range , rememberCookieName :: ByteString -- ^ Cookie name for the remember token , rememberPeriod :: Maybe Int -- ^ Remember period in seconds. Defaults to 2 weeks. , siteKey :: Key -- ^ A unique encryption key used to encrypt remember cookie , lockout :: Maybe (Int, NominalDiffTime) -- ^ Lockout after x tries, re-allow entry after y seconds , randomNumberGenerator :: RNG -- ^ Random number generator } instance IAuthBackend (AuthManager b) where save AuthManager{..} u = save backend u lookupByUserId AuthManager{..} u = lookupByUserId backend u lookupByLogin AuthManager{..} u = lookupByLogin backend u lookupByRememberToken AuthManager{..} u = lookupByRememberToken backend u destroy AuthManager{..} u = destroy backend u snap-0.14.0.6/src/Snap/Snaplet/Auth/Handlers.hs0000644000000000000000000004776612552604453017214 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} ------------------------------------------------------------------------------ -- | Pre-packaged Handlers that deal with form submissions and standard -- use-cases involving authentication. module Snap.Snaplet.Auth.Handlers where ------------------------------------------------------------------------------ import Control.Applicative import Control.Monad.State import Control.Monad.Trans.Either import Control.Monad.Trans.Maybe import Data.ByteString (ByteString) import Data.Maybe import Data.Serialize hiding (get) import Data.Time import Data.Text.Encoding (decodeUtf8) import Data.Text (Text, null, strip) import Prelude hiding (null) import Web.ClientSession ------------------------------------------------------------------------------ import Snap.Core import Snap.Snaplet import Snap.Snaplet.Auth.AuthManager import Snap.Snaplet.Auth.Handlers.Errors import Snap.Snaplet.Auth.Types import Snap.Snaplet.Session ------------------------------------------------------------------------------ ---------------------------- -- Higher level functions -- ---------------------------- ------------------------------------------------------------------------------ -- | Create a new user from just a username and password -- createUser :: Text -- ^ Username -> ByteString -- ^ Password -> Handler b (AuthManager b) (Either AuthFailure AuthUser) createUser unm pwd | null $ strip unm = return $ Left UsernameMissing | otherwise = do uExists <- usernameExists unm if uExists then return $ Left DuplicateLogin else withBackend $ \r -> liftIO $ buildAuthUser r unm pwd ------------------------------------------------------------------------------ -- | Check whether a user with the given username exists. -- usernameExists :: Text -- ^ The username to be checked -> Handler b (AuthManager b) Bool usernameExists username = withBackend $ \r -> liftIO $ isJust <$> lookupByLogin r username ------------------------------------------------------------------------------ -- | Lookup a user by her username, check given password and perform login -- loginByUsername :: Text -- ^ Username/login for user -> Password -- ^ Should be ClearText -> Bool -- ^ Set remember token? -> Handler b (AuthManager b) (Either AuthFailure AuthUser) loginByUsername _ (Encrypted _) _ = return $ Left EncryptedPassword loginByUsername unm pwd shouldRemember = do sk <- gets siteKey cn <- gets rememberCookieName rp <- gets rememberPeriod withBackend $ loginByUsername' sk cn rp where -------------------------------------------------------------------------- loginByUsername' :: (IAuthBackend t) => Key -> ByteString -> Maybe Int -> t -> Handler b (AuthManager b) (Either AuthFailure AuthUser) loginByUsername' sk cn rp r = liftIO (lookupByLogin r unm) >>= maybe (return $! Left UserNotFound) found where ---------------------------------------------------------------------- found user = checkPasswordAndLogin user pwd >>= either (return . Left) matched ---------------------------------------------------------------------- matched user | shouldRemember = do token <- gets randomNumberGenerator >>= liftIO . randomToken 64 setRememberToken sk cn rp token let user' = user { userRememberToken = Just (decodeUtf8 token) } saveUser user' return $! Right user' | otherwise = return $ Right user ------------------------------------------------------------------------------ -- | Remember user from the remember token if possible and perform login -- loginByRememberToken :: Handler b (AuthManager b) (Either AuthFailure AuthUser) loginByRememberToken = withBackend $ \impl -> do key <- gets siteKey cookieName_ <- gets rememberCookieName period <- gets rememberPeriod runEitherT $ do token <- noteT (AuthError "loginByRememberToken: no remember token") $ MaybeT $ getRememberToken key cookieName_ period user <- noteT (AuthError "loginByRememberToken: no remember token") $ MaybeT $ liftIO $ lookupByRememberToken impl $ decodeUtf8 token lift $ forceLogin user return user ------------------------------------------------------------------------------ -- | Logout the active user -- logout :: Handler b (AuthManager b) () logout = do s <- gets session withTop s $ withSession s removeSessionUserId rc <- gets rememberCookieName forgetRememberToken rc modify $ \mgr -> mgr { activeUser = Nothing } ------------------------------------------------------------------------------ -- | Return the current user; trying to remember from cookie if possible. -- currentUser :: Handler b (AuthManager b) (Maybe AuthUser) currentUser = cacheOrLookup $ withBackend $ \r -> do s <- gets session uid <- withTop s getSessionUserId case uid of Nothing -> hush <$> loginByRememberToken Just uid' -> liftIO $ lookupByUserId r uid' ------------------------------------------------------------------------------ -- | Convenience wrapper around 'rememberUser' that returns a bool result -- isLoggedIn :: Handler b (AuthManager b) Bool isLoggedIn = isJust <$> currentUser ------------------------------------------------------------------------------ -- | Create or update a given user -- saveUser :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser) saveUser u | null $ userLogin u = return $ Left UsernameMissing | otherwise = withBackend $ \r -> liftIO $ save r u ------------------------------------------------------------------------------ -- | Destroy the given user -- destroyUser :: AuthUser -> Handler b (AuthManager b) () destroyUser u = withBackend $ liftIO . flip destroy u ----------------------------------- -- Lower level helper functions -- ----------------------------------- ------------------------------------------------------------------------------ -- | Mutate an 'AuthUser', marking failed authentication -- -- This will save the user to the backend. -- markAuthFail :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser) markAuthFail u = withBackend $ \r -> do lo <- gets lockout incFailCtr u >>= checkLockout lo >>= liftIO . save r where -------------------------------------------------------------------------- incFailCtr u' = return $ u' { userFailedLoginCount = userFailedLoginCount u' + 1 } -------------------------------------------------------------------------- checkLockout lo u' = case lo of Nothing -> return u' Just (mx, wait) -> if userFailedLoginCount u' >= mx then do now <- liftIO getCurrentTime let reopen = addUTCTime wait now return $! u' { userLockedOutUntil = Just reopen } else return u' ------------------------------------------------------------------------------ -- | Mutate an 'AuthUser', marking successful authentication -- -- This will save the user to the backend. -- markAuthSuccess :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser) markAuthSuccess u = withBackend $ \r -> incLoginCtr u >>= updateIp >>= updateLoginTS >>= resetFailCtr >>= liftIO . save r where -------------------------------------------------------------------------- incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 } -------------------------------------------------------------------------- updateIp u' = do ip <- rqRemoteAddr <$> getRequest return $ u' { userLastLoginIp = userCurrentLoginIp u' , userCurrentLoginIp = Just ip } -------------------------------------------------------------------------- updateLoginTS u' = do now <- liftIO getCurrentTime return $ u' { userCurrentLoginAt = Just now , userLastLoginAt = userCurrentLoginAt u' } -------------------------------------------------------------------------- resetFailCtr u' = return $ u' { userFailedLoginCount = 0 , userLockedOutUntil = Nothing } ------------------------------------------------------------------------------ -- | Authenticate and log the user into the current session if successful. -- -- This is a mid-level function exposed to allow roll-your-own ways of looking -- up a user from the database. -- -- This function will: -- -- 1. Check the password -- -- 2. Login the user into the current session -- -- 3. Mark success/failure of the authentication trial on the user record -- checkPasswordAndLogin :: AuthUser -- ^ An existing user, somehow looked up from db -> Password -- ^ A ClearText password -> Handler b (AuthManager b) (Either AuthFailure AuthUser) checkPasswordAndLogin u pw = case userLockedOutUntil u of Just x -> do now <- liftIO getCurrentTime if now > x then auth u else return . Left $ LockedOut x Nothing -> auth u where auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser) auth user = case authenticatePassword user pw of Just e -> do markAuthFail user return $ Left e Nothing -> do forceLogin user modify (\mgr -> mgr { activeUser = Just user }) markAuthSuccess user ------------------------------------------------------------------------------ -- | Login and persist the given 'AuthUser' in the active session -- -- Meant to be used if you have other means of being sure that the person is -- who she says she is. -- forceLogin :: AuthUser -- ^ An existing user, somehow looked up from db -> Handler b (AuthManager b) (Either AuthFailure ()) forceLogin u = do s <- gets session withSession s $ case userId u of Just x -> do withTop s (setSessionUserId x) return $ Right () Nothing -> return . Left $ AuthError $ "forceLogin: Can't force the login of a user " ++ "without userId" ------------------------------------ -- Internal, non-exported helpers -- ------------------------------------ ------------------------------------------------------------------------------ getRememberToken :: (Serialize t, MonadSnap m) => Key -> ByteString -> Maybe Int -> m (Maybe t) getRememberToken sk rc rp = getSecureCookie rc sk rp ------------------------------------------------------------------------------ setRememberToken :: (Serialize t, MonadSnap m) => Key -> ByteString -> Maybe Int -> t -> m () setRememberToken sk rc rp token = setSecureCookie rc sk rp token ------------------------------------------------------------------------------ forgetRememberToken :: MonadSnap m => ByteString -> m () forgetRememberToken rc = expireCookie rc (Just "/") ------------------------------------------------------------------------------ -- | Set the current user's 'UserId' in the active session -- setSessionUserId :: UserId -> Handler b SessionManager () setSessionUserId (UserId t) = setInSession "__user_id" t ------------------------------------------------------------------------------ -- | Remove 'UserId' from active session, effectively logging the user out. removeSessionUserId :: Handler b SessionManager () removeSessionUserId = deleteFromSession "__user_id" ------------------------------------------------------------------------------ -- | Get the current user's 'UserId' from the active session -- getSessionUserId :: Handler b SessionManager (Maybe UserId) getSessionUserId = do uid <- getFromSession "__user_id" return $ liftM UserId uid ------------------------------------------------------------------------------ -- | Check password for a given user. -- -- Returns "Nothing" if check is successful and an "IncorrectPassword" error -- otherwise -- authenticatePassword :: AuthUser -- ^ Looked up from the back-end -> Password -- ^ Check against this password -> Maybe AuthFailure authenticatePassword u pw = auth where auth = case userPassword u of Nothing -> Just PasswordMissing Just upw -> check $ checkPassword pw upw check b = if b then Nothing else Just IncorrectPassword ------------------------------------------------------------------------------ -- | Wrap lookups around request-local cache -- cacheOrLookup :: Handler b (AuthManager b) (Maybe AuthUser) -- ^ Lookup action to perform if request local cache is empty -> Handler b (AuthManager b) (Maybe AuthUser) cacheOrLookup f = do au <- gets activeUser if isJust au then return au else do au' <- f modify (\mgr -> mgr { activeUser = au' }) return au' ------------------------------------------------------------------------------ -- | Register a new user by specifying login and password 'Param' fields -- registerUser :: ByteString -- ^ Login field -> ByteString -- ^ Password field -> Handler b (AuthManager b) (Either AuthFailure AuthUser) registerUser lf pf = do l <- fmap decodeUtf8 <$> getParam lf p <- getParam pf let l' = note UsernameMissing l let p' = note PasswordMissing p -- In case of multiple AuthFailure, the first available one -- will be propagated. case liftM2 (,) l' p' of Left e -> return $ Left e Right (lgn, pwd) -> createUser lgn pwd ------------------------------------------------------------------------------ -- | A 'MonadSnap' handler that processes a login form. -- -- The request paremeters are passed to 'performLogin' -- -- To make your users stay logged in for longer than the session replay -- prevention timeout, you must pass a field name as the third parameter and -- that field must be set to a value of \"1\" by the submitting form. This -- lets you use a user selectable check box. Or if you want user remembering -- always turned on, you can use a hidden form field. loginUser :: ByteString -- ^ Username field -> ByteString -- ^ Password field -> Maybe ByteString -- ^ Remember field; Nothing if you want no remember function. -> (AuthFailure -> Handler b (AuthManager b) ()) -- ^ Upon failure -> Handler b (AuthManager b) () -- ^ Upon success -> Handler b (AuthManager b) () loginUser unf pwdf remf loginFail loginSucc = runEitherT (loginUser' unf pwdf remf) >>= either loginFail (const loginSucc) ------------------------------------------------------------------------------ loginUser' :: ByteString -> ByteString -> Maybe ByteString -> EitherT AuthFailure (Handler b (AuthManager b)) AuthUser loginUser' unf pwdf remf = do mbUsername <- lift $ getParam unf mbPassword <- lift $ getParam pwdf remember <- lift $ liftM (fromMaybe False) (runMaybeT $ do field <- MaybeT $ return remf value <- MaybeT $ getParam field return $ value == "1" || value == "on") password <- noteT PasswordMissing $ hoistMaybe mbPassword username <- noteT UsernameMissing $ hoistMaybe mbUsername EitherT $ loginByUsername (decodeUtf8 username) (ClearText password) remember ------------------------------------------------------------------------------ -- | Simple handler to log the user out. Deletes user from session. -- logoutUser :: Handler b (AuthManager b) () -- ^ What to do after logging out -> Handler b (AuthManager b) () logoutUser target = logout >> target ------------------------------------------------------------------------------ -- | Require that an authenticated 'AuthUser' is present in the current -- session. -- -- This function has no DB cost - only checks to see if a user_id is present -- in the current session. -- requireUser :: SnapletLens b (AuthManager b) -- ^ Lens reference to an "AuthManager" -> Handler b v a -- ^ Do this if no authenticated user is present. -> Handler b v a -- ^ Do this if an authenticated user is present. -> Handler b v a requireUser auth bad good = do loggedIn <- withTop auth isLoggedIn if loggedIn then good else bad ------------------------------------------------------------------------------ -- | Run a function on the backend, and return the result. -- -- This uses an existential type so that the backend type doesn't -- 'escape' AuthManager. The reason that the type is Handler b -- (AuthManager v) a and not a is because anything that uses the -- backend will return an IO something, which you can liftIO, or a -- Handler b (AuthManager v) a if it uses other handler things. -- withBackend :: (forall r. (IAuthBackend r) => r -> Handler b (AuthManager v) a) -- ^ The function to run with the handler. -> Handler b (AuthManager v) a withBackend f = join $ do (AuthManager backend_ _ _ _ _ _ _ _ _) <- get return $ f backend_ ------------------------------------------------------------------------------ -- | This function generates a random password reset token and stores it in -- the database for the user. Call this function when a user forgets their -- password. Then use the token to autogenerate a link that the user can -- visit to reset their password. This function also sets a timestamp so the -- reset token can be expired. setPasswordResetToken :: Text -> Handler b (AuthManager b) (Maybe Text) setPasswordResetToken login = do tokBS <- liftIO . randomToken 40 =<< gets randomNumberGenerator let token = decodeUtf8 tokBS now <- liftIO getCurrentTime success <- modPasswordResetToken login (Just token) (Just now) return $ if success then Just token else Nothing ------------------------------------------------------------------------------ -- | Clears a user's password reset token. Call this when the user -- successfully changes their password to ensure that the password reset link -- cannot be used again. clearPasswordResetToken :: Text -> Handler b (AuthManager b) Bool clearPasswordResetToken login = modPasswordResetToken login Nothing Nothing ------------------------------------------------------------------------------ -- | Helper function used for setting and clearing the password reset token -- and associated timestamp. modPasswordResetToken :: Text -> Maybe Text -> Maybe UTCTime -> Handler v (AuthManager v) Bool modPasswordResetToken login token timestamp = do res <- runMaybeT $ do u <- MaybeT $ withBackend $ \b -> liftIO $ lookupByLogin b login lift $ saveUser $ u { userResetToken = token , userResetRequestedAt = timestamp } return () return $ maybe False (\_ -> True) res snap-0.14.0.6/src/Snap/Snaplet/Auth/SpliceHelpers.hs0000644000000000000000000001655312552604453020204 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-| Some pre-packaged splices that add convenience to a Heist-enabled application. -} module Snap.Snaplet.Auth.SpliceHelpers ( addAuthSplices , compiledAuthSplices , userCSplices , userISplices , ifLoggedIn , ifLoggedOut , loggedInUser , cIfLoggedIn , cIfLoggedOut , cLoggedInUser ) where ------------------------------------------------------------------------------ import Control.Lens import Control.Monad.Trans import Data.Maybe import Data.Monoid import qualified Data.Text as T import Data.Text.Encoding import qualified Text.XmlHtml as X import Heist import qualified Heist.Interpreted as I import qualified Heist.Compiled as C import Heist.Splices import Snap.Snaplet import Snap.Snaplet.Auth.AuthManager import Snap.Snaplet.Auth.Handlers import Snap.Snaplet.Auth.Types import Snap.Snaplet.Heist ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | Add all standard auth splices to a Heist-enabled application. -- -- This adds the following splices: -- \ -- \ -- \ addAuthSplices :: HasHeist b => Snaplet (Heist b) -> SnapletLens b (AuthManager b) -- ^ A lens reference to 'AuthManager' -> Initializer b v () addAuthSplices h auth = addConfig h sc where sc = mempty & scInterpretedSplices .~ is & scCompiledSplices .~ cs is = do "ifLoggedIn" ## ifLoggedIn auth "ifLoggedOut" ## ifLoggedOut auth "loggedInUser" ## loggedInUser auth cs = compiledAuthSplices auth ------------------------------------------------------------------------------ -- | List containing compiled splices for ifLoggedIn, ifLoggedOut, and -- loggedInUser. compiledAuthSplices :: SnapletLens b (AuthManager b) -> Splices (SnapletCSplice b) compiledAuthSplices auth = do "ifLoggedIn" ## cIfLoggedIn auth "ifLoggedOut" ## cIfLoggedOut auth "loggedInUser" ## cLoggedInUser auth ------------------------------------------------------------------------------ -- | Function to generate interpreted splices from an AuthUser. userISplices :: Monad m => AuthUser -> Splices (I.Splice m) userISplices AuthUser{..} = do "userId" ## I.textSplice $ maybe "-" unUid userId "userLogin" ## I.textSplice userLogin "userEmail" ## I.textSplice $ fromMaybe "-" userEmail "userActive" ## I.textSplice $ T.pack $ show $ isNothing userSuspendedAt "userLoginCount" ## I.textSplice $ T.pack $ show userLoginCount "userFailedCount" ## I.textSplice $ T.pack $ show userFailedLoginCount "userLoginAt" ## I.textSplice $ maybe "-" (T.pack . show) userCurrentLoginAt "userLastLoginAt" ## I.textSplice $ maybe "-" (T.pack . show) userLastLoginAt "userSuspendedAt" ## I.textSplice $ maybe "-" (T.pack . show) userSuspendedAt "userLoginIP" ## I.textSplice $ maybe "-" decodeUtf8 userCurrentLoginIp "userLastLoginIP" ## I.textSplice $ maybe "-" decodeUtf8 userLastLoginIp "userIfActive" ## ifISplice $ isNothing userSuspendedAt "userIfSuspended" ## ifISplice $ isJust userSuspendedAt ------------------------------------------------------------------------------ -- | Compiled splices for AuthUser. userCSplices :: Monad m => Splices (RuntimeSplice m AuthUser -> C.Splice m) userCSplices = fields `mappend` ifs where fields = mapV (C.pureSplice . C.textSplice) $ do "userId" ## maybe "-" unUid . userId "userLogin" ## userLogin "userEmail" ## fromMaybe "-" . userEmail "userActive" ## T.pack . show . isNothing . userSuspendedAt "userLoginCount" ## T.pack . show . userLoginCount "userFailedCount" ## T.pack . show . userFailedLoginCount "userLoginAt" ## maybe "-" (T.pack . show) . userCurrentLoginAt "userLastLoginAt" ## maybe "-" (T.pack . show) . userLastLoginAt "userSuspendedAt" ## maybe "-" (T.pack . show) . userSuspendedAt "userLoginIP" ## maybe "-" decodeUtf8 . userCurrentLoginIp "userLastLoginIP" ## maybe "-" decodeUtf8 . userLastLoginIp ifs = do "userIfActive" ## ifCSplice (isNothing . userSuspendedAt) "userIfSuspended" ## ifCSplice (isJust . userSuspendedAt) ------------------------------------------------------------------------------ -- | A splice that can be used to check for existence of a user. If a user is -- present, this will run the contents of the node. -- -- > Show this when there is a logged in user ifLoggedIn :: SnapletLens b (AuthManager b) -> SnapletISplice b ifLoggedIn auth = do chk <- lift $ withTop auth isLoggedIn case chk of True -> getParamNode >>= return . X.childNodes False -> return [] ------------------------------------------------------------------------------ -- | A splice that can be used to check for existence of a user. If a user is -- present, this will run the contents of the node. -- -- > Show this when there is a logged in user cIfLoggedIn :: SnapletLens b (AuthManager b) -> SnapletCSplice b cIfLoggedIn auth = do cs <- C.runChildren return $ C.yieldRuntime $ do chk <- lift $ withTop auth isLoggedIn case chk of True -> C.codeGen cs False -> mempty ------------------------------------------------------------------------------ -- | A splice that can be used to check for absence of a user. If a user is -- not present, this will run the contents of the node. -- -- > Show this when there is a logged in user ifLoggedOut :: SnapletLens b (AuthManager b) -> SnapletISplice b ifLoggedOut auth = do chk <- lift $ withTop auth isLoggedIn case chk of False -> getParamNode >>= return . X.childNodes True -> return [] ------------------------------------------------------------------------------ -- | A splice that can be used to check for absence of a user. If a user is -- not present, this will run the contents of the node. -- -- > Show this when there is a logged in user cIfLoggedOut :: SnapletLens b (AuthManager b) -> SnapletCSplice b cIfLoggedOut auth = do cs <- C.runChildren return $ C.yieldRuntime $ do chk <- lift $ withTop auth isLoggedIn case chk of False -> C.codeGen cs True -> mempty ------------------------------------------------------------------------------- -- | A splice that will simply print the current user's login, if -- there is one. loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b loggedInUser auth = do u <- lift $ withTop auth currentUser maybe (return []) (I.textSplice . userLogin) u ------------------------------------------------------------------------------- -- | A splice that will simply print the current user's login, if -- there is one. cLoggedInUser :: SnapletLens b (AuthManager b) -> SnapletCSplice b cLoggedInUser auth = return $ C.yieldRuntimeText $ do u <- lift $ withTop auth currentUser return $ maybe "" userLogin u snap-0.14.0.6/src/Snap/Snaplet/Auth/Types.hs0000644000000000000000000003075212552604453016543 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.Auth.Types where ------------------------------------------------------------------------------ import Control.Applicative import Control.Arrow import Control.Monad.Trans import Crypto.PasswordStore import Data.Aeson import Data.ByteString (ByteString) import qualified Data.Configurator as C import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import Data.Hashable (Hashable) import Data.Time import Data.Text (Text) import Data.Text.Encoding import Data.Typeable import Snap.Snaplet ------------------------------------------------------------------------------ -- | Password is clear when supplied by the user and encrypted later when -- returned from the db. data Password = ClearText ByteString | Encrypted ByteString deriving (Read, Show, Ord, Eq) ------------------------------------------------------------------------------ -- | Default strength level to pass into makePassword. defaultStrength :: Int defaultStrength = 12 ------------------------------------------------------------------------------- -- | The underlying encryption function, in case you need it for -- external processing. encrypt :: ByteString -> IO ByteString encrypt = flip makePassword defaultStrength ------------------------------------------------------------------------------- -- | The underlying verify function, in case you need it for external -- processing. verify :: ByteString -- ^ Cleartext -> ByteString -- ^ Encrypted reference -> Bool verify = verifyPassword ------------------------------------------------------------------------------ -- | Turn a 'ClearText' password into an 'Encrypted' password, ready to -- be stuffed into a database. encryptPassword :: Password -> IO Password encryptPassword p@(Encrypted {}) = return p encryptPassword (ClearText p) = Encrypted `fmap` encrypt p ------------------------------------------------------------------------------ checkPassword :: Password -> Password -> Bool checkPassword (ClearText pw) (Encrypted pw') = verify pw pw' checkPassword (ClearText pw) (ClearText pw') = pw == pw' checkPassword (Encrypted pw) (Encrypted pw') = pw == pw' checkPassword _ _ = error "checkPassword failed. Make sure you pass ClearText passwords" ------------------------------------------------------------------------------ -- | Authentication failures indicate what went wrong during authentication. -- They may provide useful information to the developer, although it is -- generally not advisable to show the user the exact details about why login -- failed. data AuthFailure = AuthError String | BackendError | DuplicateLogin | EncryptedPassword | IncorrectPassword | LockedOut UTCTime -- ^ Locked out until given time | PasswordMissing | UsernameMissing | UserNotFound deriving (Read, Ord, Eq, Typeable) instance Show AuthFailure where show (AuthError s) = s show (BackendError) = "Failed to store data in the backend." show (DuplicateLogin) = "This login already exists in the backend." show (EncryptedPassword) = "Cannot login with encrypted password." show (IncorrectPassword) = "The password provided was not valid." show (LockedOut time) = "The login is locked out until " ++ show time show (PasswordMissing) = "No password provided." show (UsernameMissing) = "No username provided." show (UserNotFound) = "User not found in the backend." ------------------------------------------------------------------------------ -- | Internal representation of a 'User'. By convention, we demand that the -- application is able to directly fetch a 'User' using this identifier. -- -- Think of this type as a secure, authenticated user. You should normally -- never see this type unless a user has been authenticated. newtype UserId = UserId { unUid :: Text } deriving ( Read, Show, Ord, Eq, FromJSON, ToJSON, Hashable ) ------------------------------------------------------------------------------ -- | This will be replaced by a role-based permission system. data Role = Role ByteString deriving (Read, Show, Ord, Eq) ------------------------------------------------------------------------------ -- | Type representing the concept of a User in your application. data AuthUser = AuthUser { userId :: Maybe UserId , userLogin :: Text -- We have to have an email field for password reset functionality, but we -- don't want to force users to log in with their email address. , userEmail :: Maybe Text , userPassword :: Maybe Password , userActivatedAt :: Maybe UTCTime , userSuspendedAt :: Maybe UTCTime , userRememberToken :: Maybe Text , userLoginCount :: Int , userFailedLoginCount :: Int , userLockedOutUntil :: Maybe UTCTime , userCurrentLoginAt :: Maybe UTCTime , userLastLoginAt :: Maybe UTCTime , userCurrentLoginIp :: Maybe ByteString , userLastLoginIp :: Maybe ByteString , userCreatedAt :: Maybe UTCTime , userUpdatedAt :: Maybe UTCTime , userResetToken :: Maybe Text , userResetRequestedAt :: Maybe UTCTime , userRoles :: [Role] , userMeta :: HashMap Text Value } deriving (Show,Eq) ------------------------------------------------------------------------------ -- | Default AuthUser that has all empty values. defAuthUser :: AuthUser defAuthUser = AuthUser { userId = Nothing , userLogin = "" , userEmail = Nothing , userPassword = Nothing , userActivatedAt = Nothing , userSuspendedAt = Nothing , userRememberToken = Nothing , userLoginCount = 0 , userFailedLoginCount = 0 , userLockedOutUntil = Nothing , userCurrentLoginAt = Nothing , userLastLoginAt = Nothing , userCurrentLoginIp = Nothing , userLastLoginIp = Nothing , userCreatedAt = Nothing , userUpdatedAt = Nothing , userResetToken = Nothing , userResetRequestedAt = Nothing , userRoles = [] , userMeta = HM.empty } ------------------------------------------------------------------------------ -- | Set a new password for the given user. Given password should be -- clear-text; it will be encrypted into a 'Encrypted'. setPassword :: AuthUser -> ByteString -> IO AuthUser setPassword au pass = do pw <- Encrypted <$> makePassword pass defaultStrength return $! au { userPassword = Just pw } ------------------------------------------------------------------------------ -- | Authentication settings defined at initialization time data AuthSettings = AuthSettings { asMinPasswdLen :: Int -- ^ Currently not used/checked , asRememberCookieName :: ByteString -- ^ Name of the desired remember cookie , asRememberPeriod :: Maybe Int -- ^ How long to remember when the option is used in rest of the API. -- 'Nothing' means remember until end of session. , asLockout :: Maybe (Int, NominalDiffTime) -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration]) , asSiteKey :: FilePath -- ^ Location of app's encryption key } ------------------------------------------------------------------------------ -- | Default settings for Auth. -- -- > asMinPasswdLen = 8 -- > asRememberCookieName = "_remember" -- > asRememberPeriod = Just (2*7*24*60*60) = 2 weeks -- > asLockout = Nothing -- > asSiteKey = "site_key.txt" defAuthSettings :: AuthSettings defAuthSettings = AuthSettings { asMinPasswdLen = 8 , asRememberCookieName = "_remember" , asRememberPeriod = Just (2*7*24*60*60) , asLockout = Nothing , asSiteKey = "site_key.txt" } ------------------------------------------------------------------------------ -- | Function to get auth settings from a config file. This function can be -- used by the authors of auth snaplet backends in the initializer to let the -- user configure the auth snaplet from a config file. All options are -- optional and default to what's in defAuthSettings if not supplied. -- Here's what the default options would look like in the config file: -- -- > minPasswordLen = 8 -- > rememberCookie = "_remember" -- > rememberPeriod = 1209600 # 2 weeks -- > lockout = [5, 86400] # 5 attempts locks you out for 86400 seconds -- > siteKey = "site_key.txt" authSettingsFromConfig :: Initializer b v AuthSettings authSettingsFromConfig = do config <- getSnapletUserConfig minPasswordLen <- liftIO $ C.lookup config "minPasswordLen" let pw = maybe id (\x s -> s { asMinPasswdLen = x }) minPasswordLen rememberCookie <- liftIO $ C.lookup config "rememberCookie" let rc = maybe id (\x s -> s { asRememberCookieName = x }) rememberCookie rememberPeriod <- liftIO $ C.lookup config "rememberPeriod" let rp = maybe id (\x s -> s { asRememberPeriod = Just x }) rememberPeriod lockout <- liftIO $ C.lookup config "lockout" let lo = maybe id (\x s -> s { asLockout = Just (second fromInteger x) }) lockout siteKey <- liftIO $ C.lookup config "siteKey" let sk = maybe id (\x s -> s { asSiteKey = x }) siteKey return $ (pw . rc . rp . lo . sk) defAuthSettings -------------------- -- JSON Instances -- -------------------- ------------------------------------------------------------------------------ instance ToJSON AuthUser where toJSON u = object [ "uid" .= userId u , "login" .= userLogin u , "email" .= userEmail u , "pw" .= userPassword u , "activated_at" .= userActivatedAt u , "suspended_at" .= userSuspendedAt u , "remember_token" .= userRememberToken u , "login_count" .= userLoginCount u , "failed_login_count" .= userFailedLoginCount u , "locked_until" .= userLockedOutUntil u , "current_login_at" .= userCurrentLoginAt u , "last_login_at" .= userLastLoginAt u , "current_ip" .= fmap decodeUtf8 (userCurrentLoginIp u) , "last_ip" .= fmap decodeUtf8 (userLastLoginIp u) , "created_at" .= userCreatedAt u , "updated_at" .= userUpdatedAt u , "reset_token" .= userResetToken u , "reset_requested_at" .= userResetRequestedAt u , "roles" .= userRoles u , "meta" .= userMeta u ] ------------------------------------------------------------------------------ instance FromJSON AuthUser where parseJSON (Object v) = AuthUser <$> v .: "uid" <*> v .: "login" <*> v .: "email" <*> v .: "pw" <*> v .: "activated_at" <*> v .: "suspended_at" <*> v .: "remember_token" <*> v .: "login_count" <*> v .: "failed_login_count" <*> v .: "locked_until" <*> v .: "current_login_at" <*> v .: "last_login_at" <*> fmap (fmap encodeUtf8) (v .: "current_ip") <*> fmap (fmap encodeUtf8) (v .: "last_ip") <*> v .: "created_at" <*> v .: "updated_at" <*> v .: "reset_token" <*> v .: "reset_requested_at" <*> v .:? "roles" .!= [] <*> v .: "meta" parseJSON _ = error "Unexpected JSON input" ------------------------------------------------------------------------------ instance ToJSON Password where toJSON (Encrypted x) = toJSON $ decodeUtf8 x toJSON (ClearText _) = error "ClearText passwords can't be serialized into JSON" ------------------------------------------------------------------------------ instance FromJSON Password where parseJSON = fmap (Encrypted . encodeUtf8) . parseJSON ------------------------------------------------------------------------------ instance ToJSON Role where toJSON (Role x) = toJSON $ decodeUtf8 x ------------------------------------------------------------------------------ instance FromJSON Role where parseJSON = fmap (Role . encodeUtf8) . parseJSON snap-0.14.0.6/src/Snap/Snaplet/Auth/Backends/0000755000000000000000000000000012552604453016606 5ustar0000000000000000snap-0.14.0.6/src/Snap/Snaplet/Auth/Backends/JsonFile.hs0000644000000000000000000002533212552604453020660 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module Snap.Snaplet.Auth.Backends.JsonFile ( initJsonFileAuthManager , mkJsonAuthMgr ) where import Control.Applicative import Control.Monad.State import Control.Concurrent.STM import Data.Aeson import qualified Data.Attoparsec.ByteString as Atto import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString as B import qualified Data.Map as HM import Data.Map (Map) import Data.Maybe (fromJust, isJust) import Data.Text (Text) import qualified Data.Text as T import Data.Time import Web.ClientSession import System.Directory import Snap.Snaplet import Snap.Snaplet.Auth.Types import Snap.Snaplet.Auth.AuthManager import Snap.Snaplet.Session ------------------------------------------------------------------------------ -- | Initialize a JSON file backed 'AuthManager' initJsonFileAuthManager :: AuthSettings -- ^ Authentication settings for your app -> SnapletLens b SessionManager -- ^ Lens into a 'SessionManager' auth snaplet will -- use -> FilePath -- ^ Where to store user data as JSON -> SnapletInit b (AuthManager b) initJsonFileAuthManager s l db = do makeSnaplet "JsonFileAuthManager" "A snaplet providing user authentication using a JSON-file backend" Nothing $ liftIO $ do rng <- liftIO mkRNG key <- getKey (asSiteKey s) jsonMgr <- mkJsonAuthMgr db return $! AuthManager { backend = jsonMgr , session = l , activeUser = Nothing , minPasswdLen = asMinPasswdLen s , rememberCookieName = asRememberCookieName s , rememberPeriod = asRememberPeriod s , siteKey = key , lockout = asLockout s , randomNumberGenerator = rng } ------------------------------------------------------------------------------ -- | Load/create a datafile into memory cache and return the manager. -- -- This data type can be used by itself for batch/non-handler processing. mkJsonAuthMgr :: FilePath -> IO JsonFileAuthManager mkJsonAuthMgr fp = do db <- loadUserCache fp let db' = case db of Left e -> error e Right x -> x cache <- newTVarIO db' return $! JsonFileAuthManager { memcache = cache , dbfile = fp } ------------------------------------------------------------------------------ type UserIdCache = Map UserId AuthUser instance ToJSON UserIdCache where toJSON m = toJSON $ HM.toList m instance FromJSON UserIdCache where parseJSON = fmap HM.fromList . parseJSON ------------------------------------------------------------------------------ type LoginUserCache = Map Text UserId ------------------------------------------------------------------------------ type RemTokenUserCache = Map Text UserId ------------------------------------------------------------------------------ -- | JSON user back-end stores the user data and indexes for login and token -- based logins. data UserCache = UserCache { uidCache :: UserIdCache -- ^ the actual datastore , loginCache :: LoginUserCache -- ^ fast lookup for login field , tokenCache :: RemTokenUserCache -- ^ fast lookup for remember tokens , uidCounter :: Int -- ^ user id counter } ------------------------------------------------------------------------------ defUserCache :: UserCache defUserCache = UserCache { uidCache = HM.empty , loginCache = HM.empty , tokenCache = HM.empty , uidCounter = 0 } ------------------------------------------------------------------------------ loadUserCache :: FilePath -> IO (Either String UserCache) loadUserCache fp = do chk <- doesFileExist fp case chk of True -> do d <- B.readFile fp case Atto.parseOnly json d of Left e -> return $! Left $ "Can't open JSON auth backend. Error: " ++ e Right v -> case fromJSON v of Error e -> return $! Left $ "Malformed JSON auth data store. Error: " ++ e Success db -> return $! Right db False -> do putStrLn "User JSON datafile not found. Creating a new one." return $ Right defUserCache ------------------------------------------------------------------------------ data JsonFileAuthManager = JsonFileAuthManager { memcache :: TVar UserCache , dbfile :: FilePath } ------------------------------------------------------------------------------ jsonFileSave :: JsonFileAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser) jsonFileSave mgr u = do now <- getCurrentTime oldByLogin <- lookupByLogin mgr (userLogin u) oldById <- case userId u of Nothing -> return Nothing Just x -> lookupByUserId mgr x res <- atomically $ do cache <- readTVar (memcache mgr) res <- case userId u of Nothing -> create cache now oldByLogin Just _ -> update cache now oldById case res of Left e -> return $! Left e Right (cache', u') -> do writeTVar (memcache mgr) cache' return $! Right $! (cache', u') case res of Left _ -> return $! Left BackendError Right (cache', u') -> do dumpToDisk cache' return $! Right u' where -------------------------------------------------------------------------- create :: UserCache -> UTCTime -> (Maybe AuthUser) -> STM (Either AuthFailure (UserCache, AuthUser)) create cache now old = do case old of Just _ -> return $! Left DuplicateLogin Nothing -> do new <- do let uid' = UserId . showT $ uidCounter cache + 1 let u' = u { userUpdatedAt = Just now, userId = Just uid' } return $! cache { uidCache = HM.insert uid' u' $ uidCache cache , loginCache = HM.insert (userLogin u') uid' $ loginCache cache , tokenCache = case userRememberToken u' of Nothing -> tokenCache cache Just x -> HM.insert x uid' $ tokenCache cache , uidCounter = uidCounter cache + 1 } return $! Right (new, getLastUser new) -------------------------------------------------------------------------- -- lookup old record, see what's changed and update indexes accordingly update :: UserCache -> UTCTime -> (Maybe AuthUser) -> STM (Either AuthFailure (UserCache, AuthUser)) update cache now old = case old of Nothing -> return $! Left UserNotFound Just x -> do let oldLogin = userLogin x let oldToken = userRememberToken x let uid = fromJust $ userId u let newLogin = userLogin u let newToken = userRememberToken u let lc = if oldLogin /= userLogin u then HM.insert newLogin uid $ HM.delete oldLogin $ loginCache cache else loginCache cache let tc = if oldToken /= newToken && isJust oldToken then HM.delete (fromJust oldToken) $ loginCache cache else tokenCache cache let tc' = case newToken of Just t -> HM.insert t uid tc Nothing -> tc let u' = u { userUpdatedAt = Just now } let new = cache { uidCache = HM.insert uid u' $ uidCache cache , loginCache = lc , tokenCache = tc' } return $! Right (new, u') -------------------------------------------------------------------------- -- Sync user database to disk -- Need to implement a mutex here; simult syncs could screw things up dumpToDisk c = LB.writeFile (dbfile mgr) (encode c) -------------------------------------------------------------------------- -- Gets the last added user getLastUser cache = maybe e id $ getUser cache uid where uid = UserId . showT $ uidCounter cache e = error "getLastUser failed. This should not happen." ------------------------------------------------------------------------------ instance IAuthBackend JsonFileAuthManager where save = jsonFileSave destroy = error "JsonFile: destroy is not yet implemented" lookupByUserId mgr uid = withCache mgr f where f cache = getUser cache uid lookupByLogin mgr login = withCache mgr f where f cache = getUid >>= getUser cache where getUid = HM.lookup login (loginCache cache) lookupByRememberToken mgr token = withCache mgr f where f cache = getUid >>= getUser cache where getUid = HM.lookup token (tokenCache cache) ------------------------------------------------------------------------------ withCache :: JsonFileAuthManager -> (UserCache -> a) -> IO a withCache mgr f = atomically $ do cache <- readTVar $ memcache mgr return $! f cache ------------------------------------------------------------------------------ getUser :: UserCache -> UserId -> Maybe AuthUser getUser cache uid = HM.lookup uid (uidCache cache) ------------------------------------------------------------------------------ showT :: Int -> Text showT = T.pack . show -------------------- -- JSON Instances -- -------------------- ------------------------------------------------------------------------------ instance ToJSON UserCache where toJSON uc = object [ "uidCache" .= uidCache uc , "loginCache" .= loginCache uc , "tokenCache" .= tokenCache uc , "uidCounter" .= uidCounter uc ] ------------------------------------------------------------------------------ instance FromJSON UserCache where parseJSON (Object v) = UserCache <$> v .: "uidCache" <*> v .: "loginCache" <*> v .: "tokenCache" <*> v .: "uidCounter" parseJSON _ = error "Unexpected JSON input" snap-0.14.0.6/src/Snap/Snaplet/Auth/Handlers/0000755000000000000000000000000012552604453016634 5ustar0000000000000000snap-0.14.0.6/src/Snap/Snaplet/Auth/Handlers/Errors.hs0000644000000000000000000000166112552604453020450 0ustar0000000000000000-- | An internal module that copies a few select functions -- from Control.Error.Util, as used in Snap.Snaplet.Auth.Handlers. module Snap.Snaplet.Auth.Handlers.Errors ( hush , hushT , note , noteT , hoistMaybe ) where import Control.Monad import Control.Monad.Trans.Either import Control.Monad.Trans.Maybe -- | Suppress the 'Left' value of an 'Either' hush :: Either a b -> Maybe b hush = either (const Nothing) Just -- | Suppress the 'Left' value of an 'EitherT' hushT :: (Monad m) => EitherT a m b -> MaybeT m b hushT = MaybeT . liftM hush . runEitherT -- | Tag the 'Nothing' value of a 'Maybe' note :: a -> Maybe b -> Either a b note a = maybe (Left a) Right -- | Tag the 'Nothing' value of a 'MaybeT' noteT :: (Monad m) => a -> MaybeT m b -> EitherT a m b noteT a = EitherT . liftM (note a) . runMaybeT -- | Lift a 'Maybe' to the 'MaybeT' monad hoistMaybe :: (Monad m) => Maybe b -> MaybeT m b hoistMaybe = MaybeT . return snap-0.14.0.6/src/Snap/Snaplet/Heist/0000755000000000000000000000000012552604453015247 5ustar0000000000000000snap-0.14.0.6/src/Snap/Snaplet/Heist/Compiled.hs0000644000000000000000000000637312552604453017350 0ustar0000000000000000{-| A module exporting only functions for using compiled templates. If you import the main Snap.Snaplet.Heist module, it's easy to accidentally use the interpreted render function even when you're using compiled Heist. Importing only this module will make it harder to make mistakes like that. -} module Snap.Snaplet.Heist.Compiled ( H.Heist , H.HasHeist(..) , H.SnapletHeist , H.SnapletCSplice -- * Initializer Functions -- $initializerSection , heistInit , H.heistInit' , H.heistReloader , H.addTemplates , H.addTemplatesAt , H.addConfig , H.getHeistState , H.modifyHeistState , H.withHeistState -- * Handler Functions -- $handlerSection , render , renderAs , heistServe , heistServeSingle , H.clearHeistCache ) where import Data.ByteString (ByteString) import Snap.Snaplet import Snap.Snaplet.Heist.Internal import qualified Snap.Snaplet.Heist as H import qualified Snap.Snaplet.HeistNoClass as HNC ------------------------------------------------------------------------------ -- | The 'Initializer' for 'Heist'. This function is a convenience wrapper -- around `heistInit'` that uses defaultHeistState and sets up routes for all -- the templates. It sets up a \"heistReload\" route that reloads the heist -- templates when you request it from localhost. heistInit :: FilePath -- ^ Path to templates -> SnapletInit b (Heist b) heistInit = gHeistInit HNC.cHeistServe ------------------------------------------------------------------------------ -- | Renders a compiled template as text\/html. If the given template is not -- found, this returns 'empty'. render :: H.HasHeist b => ByteString -- ^ Template name -> Handler b v () render = H.cRender ------------------------------------------------------------------------------ -- | Renders a compiled template as the given content type. If the given -- template is not found, this returns 'empty'. renderAs :: H.HasHeist b => ByteString -- ^ Content type to render with -> ByteString -- ^ Template name -> Handler b v () renderAs = H.cRenderAs ------------------------------------------------------------------------------ -- | A handler that serves all the templates (similar to 'serveDirectory'). -- If the template specified in the request path is not found, it returns -- 'empty'. Also, this function does not serve any templates beginning with -- an underscore. This gives you a way to prevent some templates from being -- served. For example, you might have a template that contains only the -- navbar of your pages, and you probably wouldn't want that template to be -- visible to the user as a standalone template. So if you put it in a file -- called \"_nav.tpl\", this function won't serve it. heistServe :: H.HasHeist b => Handler b v () heistServe = H.cHeistServe ------------------------------------------------------------------------------ -- | Handler for serving a single template (similar to 'fileServeSingle'). If -- the given template is not found, this throws an error. heistServeSingle :: H.HasHeist b => ByteString -- ^ Template name -> Handler b v () heistServeSingle = H.cHeistServeSingle snap-0.14.0.6/src/Snap/Snaplet/Heist/Generic.hs0000644000000000000000000000137712552604453017167 0ustar0000000000000000{-| A module exporting only generic functions that choose between compiled and interpreted mode based on the setting specified in the initializer. This module is most useful for writitng general snaplets that use Heist and are meant to be used in applications that might use either interpreted or compiled templates. -} module Snap.Snaplet.Heist.Generic ( Heist , HasHeist(..) , SnapletHeist , SnapletCSplice -- * Initializer Functions -- $initializerSection , addTemplates , addTemplatesAt , addConfig , getHeistState , modifyHeistState , withHeistState -- * Handler Functions -- $handlerSection , gRender , gRenderAs , gHeistServe , gHeistServeSingle , chooseMode , clearHeistCache ) where import Snap.Snaplet.Heist snap-0.14.0.6/src/Snap/Snaplet/Heist/Internal.hs0000644000000000000000000001065012552604453017361 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Snap.Snaplet.Heist.Internal where import Prelude import Control.Lens import Control.Monad.State import Control.Monad.Trans.Either import qualified Data.HashMap.Strict as Map import Data.IORef import Data.List import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Heist import Heist.Splices.Cache import System.FilePath.Posix import Snap.Core import Snap.Snaplet data DefaultMode = Compiled | Interpreted ------------------------------------------------------------------------------ -- | The state for the Heist snaplet. To use the Heist snaplet in your app -- include this in your application state and use 'heistInit' to initialize -- it. The type parameter b will typically be the base state type for your -- application. data Heist b = Configuring { _heistConfig :: IORef (HeistConfig (Handler b b), DefaultMode) } | Running { _masterConfig :: HeistConfig (Handler b b) , _heistState :: HeistState (Handler b b) , _heistCTS :: CacheTagState , _defMode :: DefaultMode } makeLenses ''Heist ------------------------------------------------------------------------------ -- | Generic initializer function that allows compiled/interpreted template -- serving to be specified by the caller. gHeistInit :: Handler b (Heist b) () -> FilePath -> SnapletInit b (Heist b) gHeistInit serve templateDir = do makeSnaplet "heist" "" Nothing $ do hs <- heistInitWorker templateDir defaultConfig addRoutes [ ("", serve) , ("heistReload", failIfNotLocal heistReloader) ] return hs where sc = set scLoadTimeSplices defaultLoadTimeSplices mempty defaultConfig = emptyHeistConfig & hcSpliceConfig .~ sc & hcNamespace .~ "" & hcErrorNotBound .~ True ------------------------------------------------------------------------------ -- | Internal worker function used by variants of heistInit. This is -- necessary because of the divide between SnapletInit and Initializer. heistInitWorker :: FilePath -> HeistConfig (Handler b b) -> Initializer b (Heist b) (Heist b) heistInitWorker templateDir initialConfig = do snapletPath <- getSnapletFilePath let tDir = snapletPath templateDir templates <- liftIO $ runEitherT (loadTemplates tDir) >>= either (error . concat) return printInfo $ T.pack $ unwords [ "...loaded" , (show $ Map.size templates) , "templates from" , tDir ] let config = over hcTemplateLocations (<> [loadTemplates tDir]) initialConfig ref <- liftIO $ newIORef (config, Compiled) -- FIXME This runs after all the initializers, but before post init -- hooks registered by other snaplets. addPostInitHook finalLoadHook return $ Configuring ref ------------------------------------------------------------------------------ -- | Hook that converts the Heist type from Configuring to Running at the end -- of initialization. finalLoadHook :: Heist b -> EitherT Text IO (Heist b) finalLoadHook (Configuring ref) = do (hc,dm) <- lift $ readIORef ref (hs,cts) <- toTextErrors $ initHeistWithCacheTag hc return $ Running hc hs cts dm where toTextErrors = bimapEitherT (T.pack . intercalate "\n") id finalLoadHook (Running _ _ _ _) = left "finalLoadHook called while running" ------------------------------------------------------------------------------ -- | Handler that triggers a template reload. For large sites, this can be -- desireable because it may be much quicker than the full site reload -- provided at the /admin/reload route. This allows you to reload only the -- heist templates This handler is automatically set up by heistInit, but if -- you use heistInit', then you can create your own route with it. heistReloader :: Handler b (Heist b) () heistReloader = do h <- get ehs <- liftIO $ runEitherT $ initHeist $ _masterConfig h either (writeText . T.pack . unlines) (\hs -> do writeText "Heist reloaded." modifyMaster $ set heistState hs h) ehs snap-0.14.0.6/src/Snap/Snaplet/Heist/Interpreted.hs0000644000000000000000000000145712552604453020077 0ustar0000000000000000{-| A module exporting only functions for using interpreted templates. If you import the main Snap.Snaplet.Heist module, it's easy to accidentally use the compiled render function even when you're using interpreted Heist. Importing only this module will make it harder to make mistakes like that. -} module Snap.Snaplet.Heist.Interpreted ( Heist , HasHeist(..) , SnapletHeist , SnapletISplice -- * Initializer Functions -- $initializerSection , heistInit , heistInit' , addTemplates , addTemplatesAt , addConfig , getHeistState , modifyHeistState , withHeistState -- * Handler Functions -- $handlerSection , render , renderAs , heistServe , heistServeSingle , heistLocal , withSplices , renderWithSplices , clearHeistCache ) where import Snap.Snaplet.Heist snap-0.14.0.6/src/Snap/Snaplet/Internal/0000755000000000000000000000000012552604453015747 5ustar0000000000000000snap-0.14.0.6/src/Snap/Snaplet/Internal/Initializer.hs0000644000000000000000000006315412552604453020577 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Snap.Snaplet.Internal.Initializer ( addPostInitHook , addPostInitHookBase , toSnapletHook , bracketInit , modifyCfg , nestSnaplet , embedSnaplet , makeSnaplet , nameSnaplet , onUnload , addRoutes , wrapSite , runInitializer , runSnaplet , combineConfig , serveSnaplet , loadAppConfig , printInfo , getRoutes , getEnvironment , modifyMaster ) where import Prelude hiding (catch) import Control.Concurrent.MVar import Control.Exception (SomeException) import Control.Lens import Control.Monad import Control.Monad.CatchIO hiding (Handler) import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Either import Control.Monad.Trans.Writer hiding (pass) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Configurator import qualified Data.Configurator.Types as C import Data.IORef import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import Snap.Http.Server import Snap.Core import Snap.Util.GZip import System.Directory import System.Directory.Tree import System.FilePath.Posix import System.IO import Snap.Snaplet.Config import qualified Snap.Snaplet.Internal.LensT as LT import qualified Snap.Snaplet.Internal.Lensed as L import Snap.Snaplet.Internal.Types ------------------------------------------------------------------------------ -- | 'get' for InitializerState. iGet :: Initializer b v (InitializerState b) iGet = Initializer $ LT.getBase ------------------------------------------------------------------------------ -- | 'modify' for InitializerState. iModify :: (InitializerState b -> InitializerState b) -> Initializer b v () iModify f = Initializer $ do b <- LT.getBase LT.putBase $ f b ------------------------------------------------------------------------------ -- | 'gets' for InitializerState. iGets :: (InitializerState b -> a) -> Initializer b v a iGets f = Initializer $ do b <- LT.getBase return $ f b ------------------------------------------------------------------------------ -- | Lets you retrieve the list of routes currently set up by an Initializer. -- This can be useful in debugging. getRoutes :: Initializer b v [ByteString] getRoutes = liftM (map fst) $ iGets _handlers ------------------------------------------------------------------------------ -- | Return the current environment string. This will be the -- environment given to 'runSnaplet' or from the command line when -- using 'serveSnaplet'. Usefully for changing behavior during -- development and testing. getEnvironment :: Initializer b v String getEnvironment = iGets _environment ------------------------------------------------------------------------------ -- | Converts a plain hook into a Snaplet hook. toSnapletHook :: (v -> EitherT Text IO v) -> (Snaplet v -> EitherT Text IO (Snaplet v)) toSnapletHook f (Snaplet cfg reset val) = do val' <- f val return $! Snaplet cfg reset val' ------------------------------------------------------------------------------ -- | Adds an IO action that modifies the current snaplet state to be run at -- the end of initialization on the state that was created. This makes it -- easier to allow one snaplet's state to be modified by another snaplet's -- initializer. A good example of this is when a snaplet has templates that -- define its views. The Heist snaplet provides the 'addTemplates' function -- which allows other snaplets to set up their own templates. 'addTemplates' -- is implemented using this function. addPostInitHook :: (v -> EitherT Text IO v) -> Initializer b v () addPostInitHook = addPostInitHook' . toSnapletHook addPostInitHook' :: (Snaplet v -> EitherT Text IO (Snaplet v)) -> Initializer b v () addPostInitHook' h = do h' <- upHook h addPostInitHookBase h' ------------------------------------------------------------------------------ -- | Variant of addPostInitHook for when you have things wrapped in a Snaplet. addPostInitHookBase :: (Snaplet b -> EitherT Text IO (Snaplet b)) -> Initializer b v () addPostInitHookBase = Initializer . lift . tell . Hook ------------------------------------------------------------------------------ -- | Helper function for transforming hooks. upHook :: (Snaplet v -> EitherT Text IO (Snaplet v)) -> Initializer b v (Snaplet b -> EitherT Text IO (Snaplet b)) upHook h = Initializer $ do l <- ask return $ upHook' l h ------------------------------------------------------------------------------ -- | Helper function for transforming hooks. upHook' :: Monad m => ALens' b a -> (a -> m a) -> b -> m b upHook' l h b = do v <- h (b ^# l) return $ storing l v b ------------------------------------------------------------------------------ -- | Modifies the Initializer's SnapletConfig. modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v () modifyCfg f = iModify $ over curConfig $ \c -> f c ------------------------------------------------------------------------------ -- | If a snaplet has a filesystem presence, this function creates and copies -- the files if they dont' already exist. setupFilesystem :: Maybe (IO FilePath) -- ^ The directory where the snaplet's reference files are -- stored. Nothing if the snaplet doesn't come with any -- files that need to be installed. -> FilePath -- ^ Directory where the files should be copied. -> Initializer b v () setupFilesystem Nothing _ = return () setupFilesystem (Just getSnapletDataDir) targetDir = do exists <- liftIO $ doesDirectoryExist targetDir unless exists $ do printInfo "...setting up filesystem" liftIO $ createDirectoryIfMissing True targetDir srcDir <- liftIO getSnapletDataDir liftIO $ readDirectoryWith (doCopy srcDir targetDir) srcDir return () where doCopy srcRoot targetRoot filename = do createDirectoryIfMissing True directory copyFile filename toDir where toDir = targetRoot makeRelative srcRoot filename directory = dropFileName toDir ------------------------------------------------------------------------------ -- | All snaplet initializers must be wrapped in a call to @makeSnaplet@, -- which handles standardized housekeeping common to all snaplets. -- Common usage will look something like -- this: -- -- @ -- fooInit :: SnapletInit b Foo -- fooInit = makeSnaplet \"foo\" \"An example snaplet\" Nothing $ do -- -- Your initializer code here -- return $ Foo 42 -- @ -- -- Note that you're writing your initializer code in the Initializer monad, -- and makeSnaplet converts it into an opaque SnapletInit type. This allows -- us to use the type system to ensure that the API is used correctly. makeSnaplet :: Text -- ^ A default id for this snaplet. This is only used when -- the end-user has not already set an id using the -- nameSnaplet function. -> Text -- ^ A human readable description of this snaplet. -> Maybe (IO FilePath) -- ^ The path to the directory holding the snaplet's reference -- filesystem content. This will almost always be the -- directory returned by Cabal's getDataDir command, but it -- has to be passed in because it is defined in a -- package-specific import. Setting this value to Nothing -- doesn't preclude the snaplet from having files in in the -- filesystem, it just means that they won't be copied there -- automatically. -> Initializer b v v -- ^ Snaplet initializer. -> SnapletInit b v makeSnaplet snapletId desc getSnapletDataDir m = SnapletInit $ do modifyCfg $ \c -> if isNothing $ _scId c then set scId (Just snapletId) c else c sid <- iGets (T.unpack . fromJust . _scId . _curConfig) topLevel <- iGets _isTopLevel unless topLevel $ do modifyCfg $ over scUserConfig (subconfig (T.pack sid)) modifyCfg $ \c -> set scFilePath (_scFilePath c "snaplets" sid) c iModify (set isTopLevel False) modifyCfg $ set scDescription desc cfg <- iGets _curConfig printInfo $ T.pack $ concat ["Initializing " ,sid ," @ /" ,B.unpack $ buildPath $ _scRouteContext cfg ] -- This has to happen here because it needs to be after scFilePath is set -- up but before the config file is read. setupFilesystem getSnapletDataDir (_scFilePath cfg) env <- iGets _environment let configLocation = _scFilePath cfg (env ++ ".cfg") liftIO $ addToConfig [Optional configLocation] (_scUserConfig cfg) mkSnaplet m ------------------------------------------------------------------------------ -- | Internal function that gets the SnapletConfig out of the initializer -- state and uses it to create a (Snaplet a). mkSnaplet :: Initializer b v v -> Initializer b v (Snaplet v) mkSnaplet m = do res <- m cfg <- iGets _curConfig setInTop <- iGets masterReloader l <- getLens let modifier = setInTop . set (cloneLens l . snapletValue) return $ Snaplet cfg modifier res ------------------------------------------------------------------------------ -- | Brackets an initializer computation, restoring curConfig after the -- computation returns. bracketInit :: Initializer b v a -> Initializer b v a bracketInit m = do s <- iGet res <- m iModify (set curConfig (_curConfig s)) return res ------------------------------------------------------------------------------ -- | Handles modifications to InitializerState that need to happen before a -- snaplet is called with either nestSnaplet or embedSnaplet. setupSnapletCall :: ByteString -> Initializer b v () setupSnapletCall rte = do curId <- iGets (fromJust . _scId . _curConfig) modifyCfg (over scAncestry (curId:)) modifyCfg (over scId (const Nothing)) unless (B.null rte) $ modifyCfg (over scRouteContext (rte:)) ------------------------------------------------------------------------------ -- | Runs another snaplet's initializer and returns the initialized Snaplet -- value. Calling an initializer with nestSnaplet gives the nested snaplet -- access to the same base state that the current snaplet has. This makes it -- possible for the child snaplet to make use of functionality provided by -- sibling snaplets. nestSnaplet :: ByteString -- ^ The root url for all the snaplet's routes. An empty -- string gives the routes the same root as the parent -- snaplet's routes. -> SnapletLens v v1 -- ^ Lens identifying the snaplet -> SnapletInit b v1 -- ^ The initializer function for the subsnaplet. -> Initializer b v (Snaplet v1) nestSnaplet rte l (SnapletInit snaplet) = with l $ bracketInit $ do setupSnapletCall rte snaplet ------------------------------------------------------------------------------ -- | Runs another snaplet's initializer and returns the initialized Snaplet -- value. The difference between this and 'nestSnaplet' is the first type -- parameter in the third argument. The \"v1 v1\" makes the child snaplet -- think that it is the top-level state, which means that it will not be able -- to use functionality provided by snaplets included above it in the snaplet -- tree. This strongly isolates the child snaplet, and allows you to eliminate -- the b type variable. The embedded snaplet can still get functionality -- from other snaplets, but only if it nests or embeds the snaplet itself. -- -- Note that this function does not change where this snaplet is located in -- the filesystem. The snaplet directory structure convention stays the same. -- Also, embedSnaplet limits the ways that snaplets can interact, so we -- usually recommend using nestSnaplet instead. However, we provide this -- function because sometimes reduced flexibility is useful. In short, if -- you don't understand what this function does for you from looking at its -- type, you probably don't want to use it. embedSnaplet :: ByteString -- ^ The root url for all the snaplet's routes. An empty -- string gives the routes the same root as the parent -- snaplet's routes. -- -- NOTE: Because of the stronger isolation provided by -- embedSnaplet, you should be more careful about using an -- empty string here. -> SnapletLens v v1 -- ^ Lens identifying the snaplet -> SnapletInit v1 v1 -- ^ The initializer function for the subsnaplet. -> Initializer b v (Snaplet v1) embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do curLens <- getLens setupSnapletCall "" chroot rte (cloneLens curLens . subSnaplet l) snaplet ------------------------------------------------------------------------------ -- | Changes the base state of an initializer. chroot :: ByteString -> SnapletLens (Snaplet b) v1 -> Initializer v1 v1 a -> Initializer b v a chroot rte l (Initializer m) = do curState <- iGet let newSetter f = masterReloader curState (over (cloneLens l) f) ((a,s), (Hook hook)) <- liftIO $ runWriterT $ LT.runLensT m id $ curState { _handlers = [], _hFilter = id, masterReloader = newSetter } let handler = chrootHandler l $ _hFilter s $ route $ _handlers s iModify $ over handlers (++[(rte,handler)]) . set cleanup (_cleanup s) addPostInitHookBase $ upHook' l hook return a ------------------------------------------------------------------------------ -- | Changes the base state of a handler. chrootHandler :: SnapletLens (Snaplet v) b' -> Handler b' b' a -> Handler b v a chrootHandler l (Handler h) = Handler $ do s <- get (a, s') <- liftSnap $ L.runLensed h id (s ^# l) modify $ storing l s' return a ------------------------------------------------------------------------------ -- | Sets a snaplet's name. All snaplets have a default name set by the -- snaplet author. This function allows you to override that name. You will -- have to do this if you have more than one instance of the same kind of -- snaplet because snaplet names must be unique. This function must -- immediately surround the snaplet's initializer. For example: -- -- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@ nameSnaplet :: Text -- ^ The snaplet name -> SnapletInit b v -- ^ The snaplet initializer function -> SnapletInit b v nameSnaplet nm (SnapletInit m) = SnapletInit $ modifyCfg (set scId (Just nm)) >> m ------------------------------------------------------------------------------ -- | Adds routing to the current 'Handler'. The new routes are merged with -- the main routing section and take precedence over existing routing that was -- previously defined. addRoutes :: [(ByteString, Handler b v ())] -> Initializer b v () addRoutes rs = do l <- getLens ctx <- iGets (_scRouteContext . _curConfig) let modRoute (r,h) = ( buildPath (r:ctx) , setPattern r >> withTop' l h) let rs' = map modRoute rs iModify (\v -> over handlers (++rs') v) where setPattern r = do p <- getRoutePattern when (isNothing p) $ setRoutePattern r ------------------------------------------------------------------------------ -- | Wraps the /base/ snaplet's routing in another handler, allowing you to run -- code before and after all routes in an application. -- -- Here are some examples of things you might do: -- -- > wrapSite (\site -> logHandlerStart >> site >> logHandlerFinished) -- > wrapSite (\site -> ensureAdminUser >> site) -- wrapSite :: (Handler b v () -> Handler b v ()) -- ^ Handler modifier function -> Initializer b v () wrapSite f0 = do f <- mungeFilter f0 iModify (\v -> over hFilter (f.) v) ------------------------------------------------------------------------------ mungeFilter :: (Handler b v () -> Handler b v ()) -> Initializer b v (Handler b b () -> Handler b b ()) mungeFilter f = do myLens <- Initializer ask return $ \m -> with' myLens $ f' m where f' (Handler m) = f $ Handler $ L.withTop id m ------------------------------------------------------------------------------ -- | Attaches an unload handler to the snaplet. The unload handler will be -- called when the server shuts down, or is reloaded. onUnload :: IO () -> Initializer b v () onUnload m = do cleanupRef <- iGets _cleanup liftIO $ atomicModifyIORef cleanupRef f where f curCleanup = (curCleanup >> m, ()) ------------------------------------------------------------------------------ -- | logInitMsg :: IORef Text -> Text -> IO () logInitMsg ref msg = atomicModifyIORef ref (\cur -> (cur `T.append` msg, ())) ------------------------------------------------------------------------------ -- | Initializers should use this function for all informational or error -- messages to be displayed to the user. On application startup they will be -- sent to the console. When executed from the reloader, they will be sent -- back to the user in the HTTP response. printInfo :: Text -> Initializer b v () printInfo msg = do logRef <- iGets _initMessages liftIO $ logInitMsg logRef (msg `T.append` "\n") ------------------------------------------------------------------------------ -- | Builds an IO reload action for storage in the SnapletState. mkReloader :: FilePath -> String -> ((Snaplet b -> Snaplet b) -> IO ()) -> IORef (IO ()) -> Initializer b b (Snaplet b) -> IO (Either Text Text) mkReloader cwd env resetter cleanupRef i = do join $ readIORef cleanupRef !res <- runInitializer' resetter env i cwd either (return . Left) good res where good (b,is) = do _ <- resetter (const b) msgs <- readIORef $ _initMessages is return $ Right msgs ------------------------------------------------------------------------------ -- | Runs a top-level snaplet in the Snap monad. runBase :: Handler b b a -> MVar (Snaplet b) -> Snap a runBase (Handler m) mvar = do !b <- liftIO (readMVar mvar) (!a, _) <- L.runLensed m id b return $! a ------------------------------------------------------------------------------ -- | Lets you change a snaplet's initial state. It's alomst like a reload, -- except that it doesn't run the initializer. It just modifies the result of -- the initializer. This can be used to let you define actions for reloading -- individual snaplets. modifyMaster :: v -> Handler b v () modifyMaster v = do modifier <- getsSnapletState _snapletModifier liftIO $ modifier v ------------------------------------------------------------------------------ -- | Internal function for running Initializers. If any exceptions were -- thrown by the initializer, this function catches them, runs any cleanup -- actions that had been registered, and returns an expanded error message -- containing the exception details as well as all messages generated by the -- initializer before the exception was thrown. runInitializer :: ((Snaplet b -> Snaplet b) -> IO ()) -> String -> Initializer b b (Snaplet b) -> IO (Either Text (Snaplet b, InitializerState b)) runInitializer resetter env b = getCurrentDirectory >>= runInitializer' resetter env b ------------------------------------------------------------------------------ runInitializer' :: ((Snaplet b -> Snaplet b) -> IO ()) -> String -> Initializer b b (Snaplet b) -> FilePath -> IO (Either Text (Snaplet b, InitializerState b)) runInitializer' resetter env b@(Initializer i) cwd = do cleanupRef <- newIORef (return ()) let reloader_ = mkReloader cwd env resetter cleanupRef b let builtinHandlers = [("/admin/reload", reloadSite)] let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing reloader_ logRef <- newIORef "" let body = runEitherT $ do ((res, s), (Hook hook)) <- lift $ runWriterT $ LT.runLensT i id $ InitializerState True cleanupRef builtinHandlers id cfg logRef env resetter res' <- hook res right (res', s) handler e = do join $ readIORef cleanupRef logMessages <- readIORef logRef return $ Left $ T.unlines [ "Initializer threw an exception..." , T.pack $ show (e :: SomeException) , "" , "...but before it died it generated the following output:" , logMessages ] catch body handler ------------------------------------------------------------------------------ -- | Given an environment and a Snaplet initializer, produce a concatenated log -- of all messages generated during initialization, a snap handler, and a -- cleanup action. The environment is an arbitrary string such as \"devel\" or -- \"production\". This string is used to determine the name of the -- configuration files used by each snaplet. If an environment of Nothing is -- used, then runSnaplet defaults to \"devel\". runSnaplet :: Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ()) runSnaplet env (SnapletInit b) = do snapletMVar <- newEmptyMVar let resetter f = modifyMVar_ snapletMVar (return . f) eRes <- runInitializer resetter (fromMaybe "devel" env) b let go (siteSnaplet,is) = do putMVar snapletMVar siteSnaplet msgs <- liftIO $ readIORef $ _initMessages is let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar cleanupAction <- readIORef $ _cleanup is return (msgs, handler, cleanupAction) either (error . ('\n':) . T.unpack) go eRes ------------------------------------------------------------------------------ -- | Given a configuration and a snap handler, complete it and produce the -- completed configuration as well as a new toplevel handler with things like -- compression and a 500 handler set up. combineConfig :: Config Snap a -> Snap () -> IO (Config Snap a, Snap ()) combineConfig config handler = do conf <- completeConfig config let catch500 = (flip catch $ fromJust $ getErrorHandler conf) let compress = if fromJust (getCompression conf) then withCompression else id let site = compress $ catch500 handler return (conf, site) ------------------------------------------------------------------------------ -- | Initialize and run a Snaplet. This function parses command-line arguments, -- runs the given Snaplet initializer, and starts an HTTP server running the -- Snaplet's toplevel 'Handler'. serveSnaplet :: Config Snap AppConfig -- ^ The configuration of the server - you can usually pass a -- default 'Config' via -- 'Snap.Http.Server.Config.defaultConfig'. -> SnapletInit b b -- ^ The snaplet initializer function. -> IO () serveSnaplet startConfig initializer = do config <- commandLineAppConfig startConfig let env = appEnvironment =<< getOther config (msgs, handler, doCleanup) <- runSnaplet env initializer (conf, site) <- combineConfig config handler createDirectoryIfMissing False "log" let serve = simpleHttpServe conf when (loggingEnabled conf) $ liftIO $ hPutStrLn stderr $ T.unpack msgs _ <- try $ serve $ site :: IO (Either SomeException ()) doCleanup where loggingEnabled = not . (== Just False) . getVerbose ------------------------------------------------------------------------------ -- | Allows you to get all of your app's config data in the IO monad without -- the web server infrastructure. loadAppConfig :: FileName -- ^ The name of the config file to look for. In snap -- applications, this is something based on the -- environment...i.e. @devel.cfg@. -> FilePath -- ^ Path to the root directory of your project. -> IO C.Config loadAppConfig cfg root = do tree <- buildL root let groups = loadAppConfig' cfg "" $ dirTree tree loadGroups groups ------------------------------------------------------------------------------ -- | Recursive worker for loadAppConfig. loadAppConfig' :: FileName -> Text -> DirTree a -> [(Text, Worth a)] loadAppConfig' cfg _prefix d@(Dir _ c) = (map ((_prefix,) . Required) $ getCfg cfg d) ++ concatMap (\a -> loadAppConfig' cfg (nextPrefix $ name a) a) snaplets where nextPrefix p = T.concat [_prefix, T.pack p, "."] snapletsDirs = filter isSnapletsDir c snaplets = concatMap (filter isDir . contents) snapletsDirs loadAppConfig' _ _ _ = [] isSnapletsDir :: DirTree t -> Bool isSnapletsDir (Dir "snaplets" _) = True isSnapletsDir _ = False isDir :: DirTree t -> Bool isDir (Dir _ _) = True isDir _ = False isCfg :: FileName -> DirTree t -> Bool isCfg cfg (File n _) = cfg == n isCfg _ _ = False getCfg :: FileName -> DirTree b -> [b] getCfg cfg (Dir _ c) = map file $ filter (isCfg cfg) c getCfg _ _ = [] snap-0.14.0.6/src/Snap/Snaplet/Internal/Lensed.hs0000644000000000000000000001232612552604453017521 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} module Snap.Snaplet.Internal.Lensed where import Control.Applicative import Control.Lens import Control.Monad import Control.Monad.Reader.Class import Control.Monad.Trans import Control.Monad.CatchIO import Control.Monad.State.Class import Control.Monad.State.Strict import Control.Category import Prelude hiding (catch, id, (.)) import Snap.Core ------------------------------------------------------------------------------ newtype Lensed b v m a = Lensed { unlensed :: ALens' b v -> v -> b -> m (a, v, b) } ------------------------------------------------------------------------------ instance Functor m => Functor (Lensed b v m) where fmap f (Lensed g) = Lensed $ \l v s -> (\(a,v',s') -> (f a, v', s')) <$> g l v s ------------------------------------------------------------------------------ instance (Functor m, Monad m) => Applicative (Lensed b v m) where pure a = Lensed $ \_ v s -> return (a, v, s) Lensed mf <*> Lensed ma = Lensed $ \l v s -> do (f, v', s') <- mf l v s (\(a,v'',s'') -> (f a, v'', s'')) <$> ma l v' s' ------------------------------------------------------------------------------ instance Monad m => Monad (Lensed b v m) where return a = Lensed $ \_ v s -> return (a, v, s) Lensed g >>= k = Lensed $ \l v s -> do (a, v', s') <- g l v s unlensed (k a) l v' s' ------------------------------------------------------------------------------ instance Monad m => MonadState v (Lensed b v m) where get = Lensed $ \_ v s -> return (v, v, s) put v' = Lensed $ \_ _ s -> return ((), v', s) instance Monad m => MonadReader (ALens' b v) (Lensed b v m) where ask = Lensed $ \l v s -> return (l, v, s) local = lensedLocal ------------------------------------------------------------------------------ lensedLocal :: Monad m => (ALens' b v -> ALens' b v') -> Lensed b v' m a -> Lensed b v m a lensedLocal f g = do l <- ask withTop (f l) g ------------------------------------------------------------------------------ instance MonadTrans (Lensed b v) where lift m = Lensed $ \_ v b -> do res <- m return (res, v, b) ------------------------------------------------------------------------------ instance MonadIO m => MonadIO (Lensed b v m) where liftIO = lift . liftIO ------------------------------------------------------------------------------ instance MonadCatchIO m => MonadCatchIO (Lensed b v m) where catch (Lensed m) f = Lensed $ \l v b -> m l v b `catch` handler l v b where handler l v b e = let Lensed h = f e in h l v b block (Lensed m) = Lensed $ \l v b -> block (m l v b) unblock (Lensed m) = Lensed $ \l v b -> unblock (m l v b) ------------------------------------------------------------------------------ instance MonadPlus m => MonadPlus (Lensed b v m) where mzero = lift mzero m `mplus` n = Lensed $ \l v b -> unlensed m l v b `mplus` unlensed n l v b ------------------------------------------------------------------------------ instance (Monad m, Alternative m) => Alternative (Lensed b v m) where empty = lift empty Lensed m <|> Lensed n = Lensed $ \l v b -> m l v b <|> n l v b ------------------------------------------------------------------------------ instance MonadSnap m => MonadSnap (Lensed b v m) where liftSnap = lift . liftSnap ------------------------------------------------------------------------------ globally :: Monad m => StateT b m a -> Lensed b v m a globally (StateT f) = Lensed $ \l v s -> liftM (\(a, s') -> (a, s' ^# l, s')) $ f (storing l v s) ------------------------------------------------------------------------------ lensedAsState :: Monad m => Lensed b v m a -> ALens' b v -> StateT b m a lensedAsState (Lensed f) l = StateT $ \s -> do (a, v', s') <- f l (s ^# l) s return (a, storing l v' s') ------------------------------------------------------------------------------ getBase :: Monad m => Lensed b v m b getBase = Lensed $ \_ v b -> return (b, v, b) ------------------------------------------------------------------------------ withTop :: Monad m => ALens' b v' -> Lensed b v' m a -> Lensed b v m a withTop l m = globally $ lensedAsState m l ------------------------------------------------------------------------------ with :: Monad m => ALens' v v' -> Lensed b v' m a -> Lensed b v m a with l g = do l' <- ask withTop (cloneLens l' . l) g ------------------------------------------------------------------------------ embed :: Monad m => ALens' v v' -> Lensed v v' m a -> Lensed b v m a embed l m = locally $ lensedAsState m l ------------------------------------------------------------------------------ locally :: Monad m => StateT v m a -> Lensed b v m a locally (StateT f) = Lensed $ \_ v s -> liftM (\(a, v') -> (a, v', s)) $ f v ------------------------------------------------------------------------------ runLensed :: Monad m => Lensed t1 b m t -> ALens' t1 b -> t1 -> m (t, t1) runLensed (Lensed f) l s = do (a, v', s') <- f l (s ^# l) s return (a, storing l v' s') snap-0.14.0.6/src/Snap/Snaplet/Internal/LensT.hs0000644000000000000000000000531512552604453017334 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} module Snap.Snaplet.Internal.LensT where import Control.Applicative import Control.Category import Control.Lens import Control.Monad.CatchIO import Control.Monad.Reader import Control.Monad.State.Class import Prelude hiding ((.), id, catch) import Snap.Core import Snap.Snaplet.Internal.RST newtype LensT b v s m a = LensT (RST (ALens' b v) s m a) deriving ( Monad , MonadTrans , Functor , Applicative , MonadIO , MonadPlus , MonadCatchIO , Alternative , MonadReader (ALens' b v) , MonadSnap ) ------------------------------------------------------------------------------ instance Monad m => MonadState v (LensT b v b m) where get = lGet put = lPut ------------------------------------------------------------------------------ getBase :: Monad m => LensT b v s m s getBase = LensT get {-# INLINE getBase #-} ------------------------------------------------------------------------------ putBase :: Monad m => s -> LensT b v s m () putBase = LensT . put {-# INLINE putBase #-} ------------------------------------------------------------------------------ lGet :: Monad m => LensT b v b m v lGet = LensT $ do !l <- ask !b <- get return $! b ^# l {-# INLINE lGet #-} ------------------------------------------------------------------------------ lPut :: Monad m => v -> LensT b v b m () lPut v = LensT $ do !l <- ask !b <- get put $! storing l v b {-# INLINE lPut #-} ------------------------------------------------------------------------------ runLensT :: Monad m => LensT b v s m a -> ALens' b v -> s -> m (a, s) runLensT (LensT m) l = runRST m l {-# INLINE runLensT #-} ------------------------------------------------------------------------------ withLensT :: Monad m => (ALens' b' v' -> ALens' b v) -> LensT b v s m a -> LensT b' v' s m a withLensT f (LensT m) = LensT $ withRST f m {-# INLINE withLensT #-} ------------------------------------------------------------------------------ withTop :: Monad m => ALens' b v' -> LensT b v' s m a -> LensT b v s m a withTop subLens = withLensT (const subLens) {-# INLINE withTop #-} ------------------------------------------------------------------------------ with :: Monad m => ALens' v v' -> LensT b v' s m a -> LensT b v s m a with subLens = withLensT (\l -> cloneLens l . subLens) snap-0.14.0.6/src/Snap/Snaplet/Internal/RST.hs0000644000000000000000000000543612552604453016763 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Snap.Snaplet.Internal.RST where import Control.Applicative import Control.Category import Control.Monad.CatchIO import Control.Monad.Reader import Control.Monad.State.Class import Prelude hiding ((.), id, catch) import Snap.Core ------------------------------------------------------------------------------ -- like RWST, but no writer to bog things down. Also assured strict, inlined -- monad bind, etc newtype RST r s m a = RST { runRST :: r -> s -> m (a, s) } evalRST :: Monad m => RST r s m a -> r -> s -> m a evalRST m r s = do (a,_) <- runRST m r s return a {-# INLINE evalRST #-} execRST :: Monad m => RST r s m a -> r -> s -> m s execRST m r s = do (_,!s') <- runRST m r s return s' {-# INLINE execRST #-} withRST :: Monad m => (r' -> r) -> RST r s m a -> RST r' s m a withRST f m = RST $ \r' s -> runRST m (f r') s {-# INLINE withRST #-} instance (Monad m) => MonadReader r (RST r s m) where ask = RST $ \r s -> return (r,s) local f m = RST $ \r s -> runRST m (f r) s instance (Functor m) => Functor (RST r s m) where fmap f m = RST $ \r s -> fmap (\(a,s') -> (f a, s')) $ runRST m r s instance (Functor m, Monad m) => Applicative (RST r s m) where pure = return (<*>) = ap instance (Functor m, MonadPlus m) => Alternative (RST r s m) where empty = mzero (<|>) = mplus instance (Monad m) => MonadState s (RST r s m) where get = RST $ \_ s -> return (s,s) put x = RST $ \_ _ -> return ((),x) mapRST :: (m (a, s) -> n (b, s)) -> RST r s m a -> RST r s n b mapRST f m = RST $ \r s -> f (runRST m r s) instance (MonadCatchIO m) => MonadCatchIO (RST r s m) where m `catch` f = RST $ \r s -> runRST m r s `catch` \e -> runRST (f e) r s block = mapRST block unblock = mapRST unblock instance (MonadSnap m) => MonadSnap (RST r s m) where liftSnap s = lift $ liftSnap s rwsBind :: Monad m => RST r s m a -> (a -> RST r s m b) -> RST r s m b rwsBind m f = RST go where go r !s = do (a, !s') <- runRST m r s runRST (f a) r s' {-# INLINE rwsBind #-} instance (Monad m) => Monad (RST r s m) where return a = RST $ \_ s -> return (a, s) (>>=) = rwsBind fail msg = RST $ \_ _ -> fail msg instance (MonadPlus m) => MonadPlus (RST r s m) where mzero = RST $ \_ _ -> mzero m `mplus` n = RST $ \r s -> runRST m r s `mplus` runRST n r s instance MonadTrans (RST r s) where lift m = RST $ \_ s -> do a <- m return $ s `seq` (a, s) instance (MonadIO m) => MonadIO (RST r s m) where liftIO = lift . liftIO snap-0.14.0.6/src/Snap/Snaplet/Internal/Types.hs0000644000000000000000000004265512552604453017423 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} #ifndef MIN_VERSION_comonad #define MIN_VERSION_comonad(x,y,z) 1 #endif module Snap.Snaplet.Internal.Types where import Control.Applicative import Control.Lens import Control.Monad.CatchIO hiding (Handler) import Control.Monad.Reader import Control.Monad.State.Class import Control.Monad.Trans.Either import Control.Monad.Trans.Writer hiding (pass) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Configurator.Types import Data.IORef import Data.Monoid import Data.Text (Text) import Snap.Core import qualified Snap.Snaplet.Internal.LensT as LT import qualified Snap.Snaplet.Internal.Lensed as L ------------------------------------------------------------------------------ -- | An opaque data type holding internal snaplet configuration data. It is -- exported publicly because the getOpaqueConfig function in MonadSnaplet -- makes implementing new instances of MonadSnaplet more convenient. data SnapletConfig = SnapletConfig { _scAncestry :: [Text] , _scFilePath :: FilePath , _scId :: Maybe Text , _scDescription :: Text , _scUserConfig :: Config , _scRouteContext :: [ByteString] , _scRoutePattern :: Maybe ByteString -- ^ Holds the actual route pattern passed to addRoutes for the -- current handler. Nothing during initialization and before route -- dispatech. , _reloader :: IO (Either Text Text) -- might change -- ^ This is the universal reload action for the top-level site. We -- can't update this in place to be a reloader for each individual -- snaplet because individual snaplets can't be reloaded in isolation -- without losing effects that subsequent hooks may have had. } makeLenses ''SnapletConfig ------------------------------------------------------------------------------ -- | Joins a reversed list of directories into a path. buildPath :: [ByteString] -> ByteString buildPath ps = B.intercalate "/" $ filter (not . B.null) $ reverse ps ------------------------------------------------------------------------------ -- | Joins a reversed list of directories into a path. getRootURL :: SnapletConfig -> ByteString getRootURL sc = buildPath $ _scRouteContext sc ------------------------------------------------------------------------------ -- | Snaplet's type parameter 's' here is user-defined and can be any Haskell -- type. A value of type @Snaplet s@ countains a couple of things: -- -- * a value of type @s@, called the \"user state\". -- -- * some bookkeeping data the framework uses to plug things together, like -- the snaplet's configuration, the snaplet's root directory on the -- filesystem, the snaplet's root URL, and so on. data Snaplet s = Snaplet { _snapletConfig :: SnapletConfig , _snapletModifier :: s -> IO () -- ^ See the _reloader comment for why we have to use this to reload -- single snaplets in isolation. This action won't actually run the -- initializer at all. It will only modify the existing state. It is -- the responsibility of the snaplet author to avoid using this in -- situations where it will destroy data in its state that was created -- by subsequent hook actions. , _snapletValue :: s } makeLenses ''Snaplet --instance Functor Snaplet where -- fmap f (Snaplet c r a) = Snaplet c r (f a) -- --instance Foldable Snaplet where -- foldMap f (Snaplet _ _ a) = f a -- --instance Traversable Snaplet where -- traverse f (Snaplet c r a) = Snaplet c r <$> f a -- --instance Comonad Snaplet where -- extract (Snaplet _ _ a) = a -- -- #if !(MIN_VERSION_comonad(3,0,0)) -- instance Extend Snaplet where -- #endif -- extend f w@(Snaplet c r _) = Snaplet c r (f w) {- ------------------------------------------------------------------------------ -- | A lens referencing the opaque SnapletConfig data type held inside -- Snaplet. snapletConfig :: SimpleLens (Snaplet a) SnapletConfig ------------------------------------------------------------------------------ -- | A lens referencing the user-defined state type wrapped by a Snaplet. snapletValue :: SimpleLens (Snaplet a) a -} type SnapletLens s a = ALens' s (Snaplet a) ------------------------------------------------------------------------------ -- | Transforms a lens of the type you get from makeLenses to an similar lens -- that is more suitable for internal use. subSnaplet :: SnapletLens a b -> SnapletLens (Snaplet a) b subSnaplet l = snapletValue . l ------------------------------------------------------------------------------ -- | The m type parameter used in the MonadSnaplet type signatures will -- usually be either Initializer or Handler, but other monads may sometimes be -- useful. -- -- Minimal complete definition: -- -- * 'withTop'', 'with'', 'getLens', and 'getOpaqueConfig'. -- class MonadSnaplet m where -- | Runs a child snaplet action in the current snaplet's context. If you -- think about snaplet lenses using a filesystem path metaphor, the lens -- supplied to this snaplet must be a relative path. In other words, the -- lens's base state must be the same as the current snaplet. with :: SnapletLens v v' -- ^ A relative lens identifying a snaplet -> m b v' a -- ^ Action from the lense's snaplet -> m b v a with l = with' (subSnaplet l) -- | Like 'with' but doesn't impose the requirement that the action -- being run be a descendant of the current snaplet. Using our filesystem -- metaphor again, the lens for this function must be an absolute -- path--it's base must be the same as the current base. withTop :: SnapletLens b v' -- ^ An \"absolute\" lens identifying a snaplet -> m b v' a -- ^ Action from the lense's snaplet -> m b v a withTop l = withTop' (subSnaplet l) -- | A variant of 'with' accepting a lens from snaplet to snaplet. Unlike -- the lens used in the above 'with' function, this lens formulation has -- an identity, which makes it useful in certain circumstances. The -- lenses generated by 'makeLenses' will not work with this function, -- however the lens returned by 'getLens' will. -- -- @with = with' . subSnaplet@ with' :: SnapletLens (Snaplet v) v' -> m b v' a -> m b v a -- Not providing a definition for this function in terms of withTop' -- allows us to avoid extra Monad type class constraints, making the type -- signature easier to read. -- with' l m = flip withTop m . (l .) =<< getLens -- | The absolute version of 'with'' withTop' :: SnapletLens (Snaplet b) v' -> m b v' a -> m b v a -- | Gets the lens for the current snaplet. getLens :: m b v (SnapletLens (Snaplet b) v) -- | Gets the current snaplet's opaque config data type. You'll only use -- this function when writing MonadSnaplet instances. getOpaqueConfig :: m b v SnapletConfig -- NOTE: We can't just use a MonadState (Snaplet v) instance for this -- because Initializer has SnapletConfig, but doesn't have a full Snaplet. ------------------------------------------------------------------------------ -- | Gets a list of the names of snaplets that are direct ancestors of the -- current snaplet. getSnapletAncestry :: (Monad (m b v), MonadSnaplet m) => m b v [Text] getSnapletAncestry = return . _scAncestry =<< getOpaqueConfig ------------------------------------------------------------------------------ -- | Gets the snaplet's path on the filesystem. getSnapletFilePath :: (Monad (m b v), MonadSnaplet m) => m b v FilePath getSnapletFilePath = return . _scFilePath =<< getOpaqueConfig ------------------------------------------------------------------------------ -- | Gets the current snaple's name. getSnapletName :: (Monad (m b v), MonadSnaplet m) => m b v (Maybe Text) getSnapletName = return . _scId =<< getOpaqueConfig ------------------------------------------------------------------------------ -- | Gets a human readable description of the snaplet. getSnapletDescription :: (Monad (m b v), MonadSnaplet m) => m b v Text getSnapletDescription = return . _scDescription =<< getOpaqueConfig ------------------------------------------------------------------------------ -- | Gets the config data structure for the current snaplet. getSnapletUserConfig :: (Monad (m b v), MonadSnaplet m) => m b v Config getSnapletUserConfig = return . _scUserConfig =<< getOpaqueConfig ------------------------------------------------------------------------------ -- | Gets the base URL for the current snaplet. Directories get added to -- the current snaplet path by calls to 'nestSnaplet'. getSnapletRootURL :: (Monad (m b v), MonadSnaplet m) => m b v ByteString getSnapletRootURL = liftM getRootURL getOpaqueConfig ------------------------------------------------------------------------------ -- | Constructs a url relative to the current snaplet. snapletURL :: (Monad (m b v), MonadSnaplet m) => ByteString -> m b v ByteString snapletURL suffix = do cfg <- getOpaqueConfig return $ buildPath (cleanSuffix : _scRouteContext cfg) where dropSlash = B.dropWhile (=='/') cleanSuffix = B.reverse $ dropSlash $ B.reverse $ dropSlash suffix ------------------------------------------------------------------------------ -- | Snaplet infrastructure is available during runtime request processing -- through the Handler monad. There aren't very many standalone functions to -- read about here, but this is deceptive. The key is in the type class -- instances. Handler is an instance of 'MonadSnap', which means it is the -- monad you will use to write all your application routes. It also has a -- 'MonadSnaplet' instance, which gives you all the functionality described -- above. newtype Handler b v a = Handler (L.Lensed (Snaplet b) (Snaplet v) Snap a) deriving ( Monad , Functor , Applicative , MonadIO , MonadPlus , MonadCatchIO , Alternative , MonadSnap) ------------------------------------------------------------------------------ -- | Gets the @Snaplet v@ from the current snaplet's state. getSnapletState :: Handler b v (Snaplet v) getSnapletState = Handler get ------------------------------------------------------------------------------ -- | Puts a new @Snaplet v@ in the current snaplet's state. putSnapletState :: Snaplet v -> Handler b v () putSnapletState = Handler . put ------------------------------------------------------------------------------ -- | Modifies the @Snaplet v@ in the current snaplet's state. modifySnapletState :: (Snaplet v -> Snaplet v) -> Handler b v () modifySnapletState f = do s <- getSnapletState putSnapletState (f s) ------------------------------------------------------------------------------ -- | Gets the @Snaplet v@ from the current snaplet's state and applies a -- function to it. getsSnapletState :: (Snaplet v -> b) -> Handler b1 v b getsSnapletState f = do s <- getSnapletState return (f s) ------------------------------------------------------------------------------ -- | The MonadState instance gives you access to the current snaplet's state. instance MonadState v (Handler b v) where get = getsSnapletState _snapletValue put v = modifySnapletState (set snapletValue v) ------------------------------------------------------------------------------ -- | The MonadState instance gives you access to the current snaplet's state. instance MonadReader v (Handler b v) where ask = getsSnapletState _snapletValue local f m = do cur <- ask put (f cur) res <- m put cur return res instance MonadSnaplet Handler where getLens = Handler ask with' !l (Handler !m) = Handler $ L.with l m withTop' !l (Handler m) = Handler $ L.withTop l m getOpaqueConfig = Handler $ gets _snapletConfig ------------------------------------------------------------------------------ -- | Like 'runBase', but it doesn't require an MVar to be executed. runPureBase :: Handler b b a -> Snaplet b -> Snap a runPureBase (Handler m) b = do (!a, _) <- L.runLensed m id b return $! a ------------------------------------------------------------------------------ -- | Gets the route pattern that matched for the handler. This lets you find -- out exactly which of the strings you used in addRoutes matched. getRoutePattern :: Handler b v (Maybe ByteString) getRoutePattern = withTop' id $ liftM _scRoutePattern getOpaqueConfig ------------------------------------------------------------------------------ -- | Sets the route pattern that matched for the handler. Use this when to -- override the default pattern which is the key to the alist passed to -- addRoutes. setRoutePattern :: ByteString -> Handler b v () setRoutePattern p = withTop' id $ modifySnapletState (set (snapletConfig . scRoutePattern) (Just p)) ------------------------------------------------------------------------------ -- | Pass if the request is not coming from localhost. failIfNotLocal :: MonadSnap m => m b -> m b failIfNotLocal m = do -- FIXME: this moves to auth once control-panel is done rip <- liftM rqRemoteAddr getRequest if not $ elem rip [ "127.0.0.1" , "localhost" , "::1" ] then pass else m ------------------------------------------------------------------------------ -- | Handler that reloads the site. reloadSite :: Handler b v () reloadSite = failIfNotLocal $ do cfg <- getOpaqueConfig !res <- liftIO $ _reloader cfg either bad good res where bad msg = do writeText $ "Error reloading site!\n\n" writeText msg good msg = do writeText msg writeText $ "Site successfully reloaded.\n" ------------------------------------------------------------------------------ -- | This function brackets a Handler action in resource acquisition and -- release. Like 'bracketSnap', this is provided because MonadCatchIO's -- 'bracket' function doesn't work properly in the case of a short-circuit -- return from the action being bracketed. -- -- In order to prevent confusion regarding the effects of the -- aquisition and release actions on the Handler state, this function -- doesn't accept Handler actions for the acquire or release actions. -- -- This function will run the release action in all cases where the -- acquire action succeeded. This includes the following behaviors -- from the bracketed Snap action. -- -- 1. Normal completion -- -- 2. Short-circuit completion, either from calling 'fail' or 'finishWith' -- -- 3. An exception being thrown. bracketHandler :: IO a -> (a -> IO x) -> (a -> Handler b v c) -> Handler b v c bracketHandler begin end f = Handler . L.Lensed $ \l v b -> do bracketSnap begin end $ \a -> case f a of Handler m -> L.unlensed m l v b ------------------------------------------------------------------------------ -- | Information about a partially constructed initializer. Used to -- automatically aggregate handlers and cleanup actions. data InitializerState b = InitializerState { _isTopLevel :: Bool , _cleanup :: IORef (IO ()) , _handlers :: [(ByteString, Handler b b ())] -- ^ Handler routes built up and passed to route. , _hFilter :: Handler b b () -> Handler b b () -- ^ Generic filtering of handlers , _curConfig :: SnapletConfig -- ^ This snaplet config is the incrementally built config for -- whatever snaplet is currently being constructed. , _initMessages :: IORef Text , _environment :: String , masterReloader :: (Snaplet b -> Snaplet b) -> IO () -- ^ We can't just hae a simple MVar here because MVars can't be -- chrooted. } ------------------------------------------------------------------------------ -- | Wrapper around IO actions that modify state elements created during -- initialization. newtype Hook a = Hook (Snaplet a -> EitherT Text IO (Snaplet a)) instance Monoid (Hook a) where mempty = Hook return (Hook a) `mappend` (Hook b) = Hook (a >=> b) ------------------------------------------------------------------------------ -- | Monad used for initializing snaplets. newtype Initializer b v a = Initializer (LT.LensT (Snaplet b) (Snaplet v) (InitializerState b) (WriterT (Hook b) IO) a) deriving (Applicative, Functor, Monad, MonadIO) makeLenses ''InitializerState instance MonadSnaplet Initializer where getLens = Initializer ask with' !l (Initializer !m) = Initializer $ LT.with l m withTop' !l (Initializer m) = Initializer $ LT.withTop l m getOpaqueConfig = Initializer $ liftM _curConfig LT.getBase ------------------------------------------------------------------------------ -- | Opaque newtype which gives us compile-time guarantees that the user is -- using makeSnaplet and either nestSnaplet or embedSnaplet correctly. newtype SnapletInit b v = SnapletInit (Initializer b v (Snaplet v)) snap-0.14.0.6/src/Snap/Snaplet/Session/0000755000000000000000000000000012552604453015616 5ustar0000000000000000snap-0.14.0.6/src/Snap/Snaplet/Session/Common.hs0000644000000000000000000000343112552604453017403 0ustar0000000000000000------------------------------------------------------------------------------ -- | This module contains functionality common among multiple back-ends. -- module Snap.Snaplet.Session.Common ( RNG , mkRNG , withRNG , randomToken , mkCSRFToken ) where ------------------------------------------------------------------------------ import Control.Applicative import Control.Concurrent import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.Text.Encoding as T import Data.Text (Text) import Numeric import System.Random.MWC ------------------------------------------------------------------------------ -- | High speed, mutable random number generator state newtype RNG = RNG (MVar GenIO) ------------------------------------------------------------------------------ -- | Perform given action, mutating the RNG state withRNG :: RNG -> (GenIO -> IO a) -> IO a withRNG (RNG rng) m = withMVar rng m ------------------------------------------------------------------------------ -- | Create a new RNG mkRNG :: IO RNG mkRNG = withSystemRandom (newMVar >=> return . RNG) ------------------------------------------------------------------------------ -- | Generates a random salt of given length randomToken :: Int -> RNG -> IO ByteString randomToken n rng = do is <- withRNG rng $ \gen -> sequence . take n . repeat $ mk gen return . B.pack . concat . map (flip showHex "") $ is where mk :: GenIO -> IO Int mk = uniformR (0,15) ------------------------------------------------------------------------------ -- | Generate a randomized CSRF token mkCSRFToken :: RNG -> IO Text mkCSRFToken rng = T.decodeUtf8 <$> randomToken 40 rng snap-0.14.0.6/src/Snap/Snaplet/Session/SecureCookie.hs0000644000000000000000000000665412552604453020545 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ -- | This is a support module meant to back all session back-end -- implementations. -- -- It gives us an encrypted and timestamped cookie that can store an arbitrary -- serializable payload. For security, it will: -- -- * Encrypt its payload together with a timestamp. -- -- * Check the timestamp for session expiration everytime you read from the -- cookie. This will limit intercept-and-replay attacks by disallowing -- cookies older than the timeout threshold. module Snap.Snaplet.Session.SecureCookie where ------------------------------------------------------------------------------ import Control.Applicative import Control.Monad import Control.Monad.Trans import Data.ByteString (ByteString) import Data.Time import Data.Time.Clock.POSIX import Data.Serialize import Snap.Core import Web.ClientSession ------------------------------------------------------------------------------ -- | Serialize UTCTime --instance Serialize UTCTime where -- put t = put (round (utcTimeToPOSIXSeconds t) :: Integer) -- get = posixSecondsToUTCTime . fromInteger <$> get ------------------------------------------------------------------------------ -- | Arbitrary payload with timestamp. type SecureCookie t = (UTCTime, t) ------------------------------------------------------------------------------ -- Get the payload back getSecureCookie :: (MonadSnap m, Serialize t) => ByteString -- ^ Cookie name -> Key -- ^ Encryption key -> Maybe Int -- ^ Timeout in seconds -> m (Maybe t) getSecureCookie name key timeout = do rqCookie <- getCookie name rspCookie <- getResponseCookie name <$> getResponse let ck = rspCookie `mplus` rqCookie let val = fmap cookieValue ck >>= decrypt key >>= return . decode let val' = val >>= either (const Nothing) Just case val' of Nothing -> return Nothing Just (ts, t) -> do to <- checkTimeout timeout $ posixSecondsToUTCTime $ fromInteger ts return $ case to of True -> Nothing False -> Just t ------------------------------------------------------------------------------ -- | Inject the payload setSecureCookie :: (MonadSnap m, Serialize t) => ByteString -- ^ Cookie name -> Key -- ^ Encryption key -> Maybe Int -- ^ Max age in seconds -> t -- ^ Serializable payload -> m () setSecureCookie name key to val = do t <- liftIO getCurrentTime let seconds = round (utcTimeToPOSIXSeconds t) :: Integer let expire = to >>= Just . flip addUTCTime t . fromIntegral val' <- liftIO . encryptIO key . encode $ (seconds, val) let nc = Cookie name val' expire Nothing (Just "/") False True modifyResponse $ addResponseCookie nc ------------------------------------------------------------------------------ -- | Validate session against timeout policy. -- -- * If timeout is set to 'Nothing', never trigger a time-out. -- -- * Otherwise, do a regular time-out check based on current time and given -- timestamp. checkTimeout :: (MonadSnap m) => Maybe Int -> UTCTime -> m Bool checkTimeout Nothing _ = return False checkTimeout (Just x) t0 = do t1 <- liftIO getCurrentTime return $ t1 > addUTCTime (fromIntegral x) t0 snap-0.14.0.6/src/Snap/Snaplet/Session/SessionManager.hs0000644000000000000000000000375512552604453021102 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-| This module is meant to be used mainly by Session backend developers, who would naturally need access to ISessionManager class internals. You can also use it if you need low-level access to the backend functionality.-} module Snap.Snaplet.Session.SessionManager where ------------------------------------------------------------------------------- import Data.Text (Text) import Prelude hiding (lookup) ------------------------------------------------------------------------------- import Snap.Core (Snap) ------------------------------------------------------------------------------- -- | Any Haskell record that is a member of the 'ISessionManager' -- typeclass can be stuffed inside a 'SessionManager' to enable all -- session-related functionality. -- -- To use sessions in your application, just find a Backend that would -- produce one for you inside of your 'Initializer'. See -- 'initCookieSessionManager' in -- 'Snap.Snaplet.Session.Backends.CookieSession' for a built-in option -- that would get you started. data SessionManager = forall a. ISessionManager a => SessionManager a class ISessionManager r where -- | Load a session from given payload. -- -- Will always be called before any other operation. If possible, cache and -- do nothing when called multiple times within the same request cycle. load :: r -> Snap r -- | Commit session, return a possibly updated paylaod commit :: r -> Snap () -- | Reset session reset :: r -> Snap r -- | Touch session touch :: r -> r -- | Insert a key-value pair into session insert :: Text -> Text -> r -> r -- | Lookup a key in session lookup :: Text -> r -> (Maybe Text) -- | Delete a key in session delete :: Text -> r -> r -- | Return a session-specific CSRF protection token. See 'mkCSRFToken' for -- help in creating the value. csrf :: r -> Text -- | Return all key-value pairs as an association list toList :: r -> [(Text,Text)] snap-0.14.0.6/src/Snap/Snaplet/Session/Backends/0000755000000000000000000000000012552604453017330 5ustar0000000000000000snap-0.14.0.6/src/Snap/Snaplet/Session/Backends/CookieSession.hs0000644000000000000000000001724512552604453022452 0ustar0000000000000000------------------------------------------------------------------------------ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.Session.Backends.CookieSession ( initCookieSessionManager ) where ------------------------------------------------------------------------------ import Control.Applicative import Control.Monad.Reader import Data.ByteString (ByteString) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import Data.Serialize (Serialize) import qualified Data.Serialize as S import Data.Text (Text) import Data.Text.Encoding import Data.Typeable import Snap.Core (Snap) import Web.ClientSession ------------------------------------------------------------------------------ import Snap.Snaplet import Snap.Snaplet.Session import Snap.Snaplet.Session.SessionManager ------------------------------------------------------------------------------- ------------------------------------------------------------------------------ -- | Session data are kept in a 'HashMap' for this backend -- type Session = HashMap Text Text ------------------------------------------------------------------------------ -- | This is what the 'Payload' will be for the CookieSession backend -- data CookieSession = CookieSession { csCSRFToken :: Text , csSession :: Session } deriving (Eq, Show) ------------------------------------------------------------------------------ instance Serialize CookieSession where put (CookieSession a b) = S.put (encodeUtf8 a, map encodeTuple $ HM.toList b) get = let unpack (a,b) = CookieSession (decodeUtf8 a) (HM.fromList $ map decodeTuple b) in unpack <$> S.get encodeTuple :: (Text, Text) -> (ByteString, ByteString) encodeTuple (a,b) = (encodeUtf8 a, encodeUtf8 b) decodeTuple :: (ByteString, ByteString) -> (Text, Text) decodeTuple (a,b) = (decodeUtf8 a, decodeUtf8 b) ------------------------------------------------------------------------------ mkCookieSession :: RNG -> IO CookieSession mkCookieSession rng = do t <- liftIO $ mkCSRFToken rng return $ CookieSession t HM.empty ------------------------------------------------------------------------------ -- | The manager data type to be stuffed into 'SessionManager' -- data CookieSessionManager = CookieSessionManager { session :: Maybe CookieSession -- ^ Per request cache for 'CookieSession' , siteKey :: Key -- ^ A long encryption key used for secure cookie transport , cookieName :: ByteString -- ^ Cookie name for the session system , timeOut :: Maybe Int -- ^ Session cookies will be considered "stale" after this many -- seconds. , randomNumberGenerator :: RNG -- ^ handle to a random number generator } deriving (Typeable) ------------------------------------------------------------------------------ loadDefSession :: CookieSessionManager -> IO CookieSessionManager loadDefSession mgr@(CookieSessionManager ses _ _ _ rng) = case ses of Nothing -> do ses' <- mkCookieSession rng return $! mgr { session = Just ses' } Just _ -> return mgr ------------------------------------------------------------------------------ modSession :: (Session -> Session) -> CookieSession -> CookieSession modSession f (CookieSession t ses) = CookieSession t (f ses) ------------------------------------------------------------------------------ -- | Initialize a cookie-backed session, returning a 'SessionManager' to be -- stuffed inside your application's state. This 'SessionManager' will enable -- the use of all session storage functionality defined in -- 'Snap.Snaplet.Session' -- initCookieSessionManager :: FilePath -- ^ Path to site-wide encryption key -> ByteString -- ^ Session cookie name -> Maybe Int -- ^ Session time-out (replay attack protection) -> SnapletInit b SessionManager initCookieSessionManager fp cn to = makeSnaplet "CookieSession" "A snaplet providing sessions via HTTP cookies." Nothing $ liftIO $ do key <- getKey fp rng <- liftIO mkRNG return $! SessionManager $ CookieSessionManager Nothing key cn to rng ------------------------------------------------------------------------------ instance ISessionManager CookieSessionManager where -------------------------------------------------------------------------- load mgr@(CookieSessionManager r _ _ _ _) = case r of Just _ -> return mgr Nothing -> do pl <- getPayload mgr case pl of Nothing -> liftIO $ loadDefSession mgr Just (Payload x) -> do let c = S.decode x case c of Left _ -> liftIO $ loadDefSession mgr Right cs -> return $ mgr { session = Just cs } -------------------------------------------------------------------------- commit mgr@(CookieSessionManager r _ _ _ rng) = do pl <- case r of Just r' -> return . Payload $ S.encode r' Nothing -> liftIO (mkCookieSession rng) >>= return . Payload . S.encode setPayload mgr pl -------------------------------------------------------------------------- reset mgr = do cs <- liftIO $ mkCookieSession (randomNumberGenerator mgr) return $ mgr { session = Just cs } -------------------------------------------------------------------------- touch = id -------------------------------------------------------------------------- insert k v mgr@(CookieSessionManager r _ _ _ _) = case r of Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' } Nothing -> mgr -------------------------------------------------------------------------- lookup k (CookieSessionManager r _ _ _ _) = r >>= HM.lookup k . csSession -------------------------------------------------------------------------- delete k mgr@(CookieSessionManager r _ _ _ _) = case r of Just r' -> mgr { session = Just $ modSession (HM.delete k) r' } Nothing -> mgr -------------------------------------------------------------------------- csrf (CookieSessionManager r _ _ _ _) = case r of Just r' -> csCSRFToken r' Nothing -> "" -------------------------------------------------------------------------- toList (CookieSessionManager r _ _ _ _) = case r of Just r' -> HM.toList . csSession $ r' Nothing -> [] ------------------------------------------------------------------------------ -- | A session payload to be stored in a SecureCookie. newtype Payload = Payload ByteString deriving (Eq, Show, Ord, Serialize) ------------------------------------------------------------------------------ -- | Get the current client-side value getPayload :: CookieSessionManager -> Snap (Maybe Payload) getPayload mgr = getSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr) ------------------------------------------------------------------------------ -- | Set the client-side value setPayload :: CookieSessionManager -> Payload -> Snap () setPayload mgr x = setSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr) x snap-0.14.0.6/test/0000755000000000000000000000000012552604453012054 5ustar0000000000000000snap-0.14.0.6/test/runTestsAndCoverage.sh0000755000000000000000000000212112552604453016335 0ustar0000000000000000#!/bin/sh set -e if [ -z "$DEBUG" ]; then export DEBUG=snap-testsuite fi SUITE=./dist/build/snap-testsuite/snap-testsuite rm -f snap-testsuite.tix if [ ! -f $SUITE ]; then cat </dev/null 2>&1 cat <= 1.8 Flag old-base default: False manual: False Executable snap-testsuite hs-source-dirs: ../src suite main-is: TestSuite.hs build-depends: Glob >= 0.5 && < 0.8, HUnit >= 1.2 && < 2, QuickCheck >= 2.3.0.2, blaze-builder >= 0.3 && < 0.4, http-streams >= 0.4.0.1 && < 0.8, process == 1.*, smallcheck >= 0.6 && < 1.2, test-framework >= 0.6 && < 0.9, test-framework-hunit >= 0.2.7 && < 0.4, test-framework-quickcheck2 >= 0.2.12.1 && < 0.4, test-framework-smallcheck >= 0.1 && < 0.3, unix >= 2.2.0.0 && < 2.8, MonadCatchIO-transformers >= 0.2 && < 0.4, aeson >= 0.6 && < 0.10, attoparsec >= 0.10 && < 0.13, bytestring >= 0.9.1 && < 0.11, cereal >= 0.3 && < 0.5, clientsession >= 0.8 && < 0.10, comonad >= 1.1 && < 4.3, configurator >= 0.1 && < 0.4, containers >= 0.3 && < 0.6, directory >= 1.0 && < 1.3, directory-tree >= 0.10 && < 0.13, dlist >= 0.5 && < 0.8, errors >= 1.4 && < 1.5, filepath >= 1.1 && < 1.4, -- Blacklist bad versions of hashable hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3), heist >= 0.14 && < 0.15, logict >= 0.4.2 && < 0.7, mtl > 2.0 && < 2.3, mwc-random >= 0.8 && < 0.14, pwstore-fast >= 2.2 && < 2.5, regex-posix >= 0.95 && < 1, snap-core >= 0.9 && < 0.11, snap-server >= 0.9 && < 0.11, stm >= 2.2 && < 2.5, syb >= 0.1 && < 0.5, text >= 0.11 && < 1.3, time >= 1.1 && < 1.5, transformers >= 0.2 && < 0.5, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.7.1 && < 0.12, vector-algorithms >= 0.4 && < 0.7, xmlhtml >= 0.1 && < 0.3 if flag(old-base) build-depends: base >= 4 && < 4.4, lens >= 3.7.6 && < 3.8 else build-depends: base >= 4.4 && < 5, lens >= 3.7.6 && < 4.13 extensions: BangPatterns, CPP, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, NoMonomorphismRestriction, OverloadedStrings, PackageImports, Rank2Types, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeOperators, TypeSynonymInstances ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind Executable app hs-source-dirs: ../src suite main-is: AppMain.hs build-depends: MonadCatchIO-transformers >= 0.2 && < 0.4, aeson >= 0.6 && < 0.10, attoparsec >= 0.10 && < 0.13, bytestring >= 0.9.1 && < 0.11, cereal >= 0.3 && < 0.5, clientsession >= 0.8 && < 0.10, comonad >= 1.1 && < 4.3, configurator >= 0.1 && < 0.4, containers >= 0.3 && < 0.6, directory >= 1.0 && < 1.3, directory-tree >= 0.10 && < 0.13, dlist >= 0.5 && < 0.8, errors >= 1.4 && < 1.5, filepath >= 1.1 && < 1.4, -- Blacklist bad versions of hashable hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3), heist >= 0.14 && < 0.15, logict >= 0.4.2 && < 0.7, mtl > 2.0 && < 2.3, mwc-random >= 0.8 && < 0.14, pwstore-fast >= 2.2 && < 2.5, regex-posix >= 0.95 && < 1, snap-core >= 0.9 && < 0.11, snap-server >= 0.9 && < 0.11, stm >= 2.2 && < 2.5, syb >= 0.1 && < 0.5, text >= 0.11 && < 1.3, time >= 1.1 && < 1.5, transformers >= 0.2 && < 0.5, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.7.1 && < 0.12, vector-algorithms >= 0.4 && < 0.7, xmlhtml >= 0.1 && < 0.3 if flag(old-base) build-depends: base >= 4 && < 4.4, lens >= 3.7.6 && < 3.8 else build-depends: base >= 4.4 && < 5, lens >= 3.7.6 && < 4.13 extensions: BangPatterns, CPP, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, NoMonomorphismRestriction, OverloadedStrings, PackageImports, Rank2Types, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeOperators, TypeSynonymInstances ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind Executable nesttest hs-source-dirs: ../src suite main-is: NestTest.hs build-depends: Glob >= 0.5 && < 0.8, HUnit >= 1.2 && < 2, QuickCheck >= 2.3.0.2, http-streams >= 0.4.0.1 && < 0.8, process == 1.*, smallcheck >= 0.6 && < 1.2, test-framework >= 0.6 && < 0.9, test-framework-hunit >= 0.2.7 && < 0.4, test-framework-quickcheck2 >= 0.2.12.1 && < 0.4, test-framework-smallcheck >= 0.1 && < 0.3, unix >= 2.2.0.0 && < 2.8, MonadCatchIO-transformers >= 0.2 && < 0.4, aeson >= 0.6 && < 0.10, attoparsec >= 0.10 && < 0.13, bytestring >= 0.9.1 && < 0.11, cereal >= 0.3 && < 0.5, clientsession >= 0.8 && < 0.10, comonad >= 1.1 && < 4.3, configurator >= 0.1 && < 0.4, containers >= 0.3 && < 0.6, directory >= 1.0 && < 1.3, directory-tree >= 0.10 && < 0.13, dlist >= 0.5 && < 0.8, errors >= 1.4 && < 1.5, filepath >= 1.1 && < 1.4, -- Blacklist bad versions of hashable hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3), heist >= 0.14 && < 0.15, logict >= 0.4.2 && < 0.7, mtl > 2.0 && < 2.3, mwc-random >= 0.8 && < 0.14, pwstore-fast >= 2.2 && < 2.5, regex-posix >= 0.95 && < 1, snap-core >= 0.9 && < 0.11, snap-server >= 0.9 && < 0.11, stm >= 2.2 && < 2.5, syb >= 0.1 && < 0.5, text >= 0.11 && < 1.3, time >= 1.1 && < 1.5, transformers >= 0.2 && < 0.5, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.7.1 && < 0.12, vector-algorithms >= 0.4 && < 0.7, xmlhtml >= 0.1 && < 0.3 if flag(old-base) build-depends: base >= 4 && < 4.4, lens >= 3.7.6 && < 3.8 else build-depends: base >= 4.4 && < 5, lens >= 3.7.6 && < 4.13 extensions: BangPatterns, CPP, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, NoMonomorphismRestriction, OverloadedStrings, PackageImports, Rank2Types, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeOperators, TypeSynonymInstances ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind snap-0.14.0.6/test/foosnaplet/0000755000000000000000000000000012552604453014226 5ustar0000000000000000snap-0.14.0.6/test/foosnaplet/devel.cfg0000644000000000000000000000003612552604453016005 0ustar0000000000000000fooSnapletField = "fooValue" snap-0.14.0.6/test/foosnaplet/templates/0000755000000000000000000000000012552604453016224 5ustar0000000000000000snap-0.14.0.6/test/foosnaplet/templates/foopage.tpl0000644000000000000000000000002212552604453020357 0ustar0000000000000000foo template page snap-0.14.0.6/test/non-cabal-appdir/0000755000000000000000000000000012552604453015163 5ustar0000000000000000snap-0.14.0.6/test/non-cabal-appdir/bad.tpl0000644000000000000000000000001612552604453016427 0ustar0000000000000000 snap-0.14.0.6/test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl0000644000000000000000000000003712552604453023720 0ustar0000000000000000baz template page snap-0.14.0.6/test/non-cabal-appdir/snaplets/embedded/0000755000000000000000000000000012552604453020545 5ustar0000000000000000snap-0.14.0.6/test/non-cabal-appdir/snaplets/embedded/extra-templates/0000755000000000000000000000000012552604453023664 5ustar0000000000000000snap-0.14.0.6/test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl0000644000000000000000000000003212552604453025523 0ustar0000000000000000This is an extra template snap-0.14.0.6/test/non-cabal-appdir/snaplets/embedded/snaplets/0000755000000000000000000000000012552604453022376 5ustar0000000000000000snap-0.14.0.6/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/0000755000000000000000000000000012552604453023512 5ustar0000000000000000snap-0.14.0.6/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/0000755000000000000000000000000012552604453025510 5ustar0000000000000000snap-0.14.0.6/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl0000644000000000000000000000004112552604453030612 0ustar0000000000000000embedded snaplet page snap-0.14.0.6/test/non-cabal-appdir/snaplets/heist/0000755000000000000000000000000012552604453020130 5ustar0000000000000000snap-0.14.0.6/test/non-cabal-appdir/snaplets/heist/templates/0000755000000000000000000000000012552604453022126 5ustar0000000000000000snap-0.14.0.6/test/non-cabal-appdir/snaplets/heist/templates/index.tpl0000644000000000000000000000001312552604453023750 0ustar0000000000000000index page snap-0.14.0.6/test/non-cabal-appdir/snaplets/heist/templates/page.tpl0000644000000000000000000000013112552604453023556 0ustar0000000000000000 Example App snap-0.14.0.6/test/non-cabal-appdir/snaplets/heist/templates/session.tpl0000644000000000000000000000001312552604453024324 0ustar0000000000000000 snap-0.14.0.6/test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl0000644000000000000000000000003112552604453024755 0ustar0000000000000000splice page snap-0.14.0.6/test/suite/0000755000000000000000000000000012552604453013205 5ustar0000000000000000snap-0.14.0.6/test/suite/AppMain.hs0000644000000000000000000000025612552604453015071 0ustar0000000000000000module Main where import Snap.Http.Server.Config import Snap.Snaplet import Blackbox.App main :: IO () main = serveSnaplet defaultConfig app snap-0.14.0.6/test/suite/NestTest.hs0000644000000000000000000000431212552604453015312 0ustar0000000000000000{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} module Main where import Prelude hiding ((.)) import Control.Lens import Control.Monad.State import qualified Data.Text as T import Snap.Http.Server.Config import Snap.Core import Snap.Util.FileServe import Snap.Snaplet import Snap.Snaplet.Heist import Heist import Heist.Interpreted -- If we universally quantify FooSnaplet to get rid of the type parameter -- mkLabels throws an error "Can't reify a GADT data constructor" data FooSnaplet = FooSnaplet { _fooHeist :: Snaplet (Heist FooSnaplet) , _fooVal :: Int } makeLenses ''FooSnaplet instance HasHeist FooSnaplet where heistLens = subSnaplet fooHeist fooInit :: SnapletInit FooSnaplet FooSnaplet fooInit = makeSnaplet "foosnaplet" "foo snaplet" Nothing $ do hs <- nestSnaplet "heist" fooHeist $ heistInit "templates" addTemplates hs "foo" rootUrl <- getSnapletRootURL fooLens <- getLens addRoutes [("fooRootUrl", writeBS rootUrl) ,("aoeuhtns", renderWithSplices "foo/foopage" ("asplice" ## fooSplice fooLens)) ,("", heistServe) ] return $ FooSnaplet hs 42 --fooSplice :: (Lens (Snaplet b) (Snaplet (FooSnaplet b))) -- -> SnapletSplice (Handler b b) fooSplice :: (SnapletLens (Snaplet b) FooSnaplet) -> SnapletISplice b fooSplice fooLens = do val <- lift $ with' fooLens $ gets _fooVal textSplice $ T.pack $ "splice value" ++ (show val) ------------------------------------------------------------------------------ data App = App { _foo :: Snaplet (FooSnaplet) } makeLenses ''App app :: SnapletInit App App app = makeSnaplet "app" "nested snaplet application" Nothing $ do fs <- embedSnaplet "foo" foo fooInit addRoutes [ ("/hello", writeText "hello world") , ("/public", serveDirectory "public") ] return $ App fs main :: IO () main = serveSnaplet defaultConfig app snap-0.14.0.6/test/suite/SafeCWD.hs0000644000000000000000000000141512552604453014756 0ustar0000000000000000module SafeCWD ( inDir , removeDirectoryRecursiveSafe ) where import Control.Concurrent.QSem import Control.Exception import Control.Monad import System.Directory import System.IO.Unsafe sem :: QSem sem = unsafePerformIO $ newQSem 1 {-# NOINLINE sem #-} inDir :: Bool -> FilePath -> IO a -> IO a inDir startClean dir action = bracket before after (const action) where before = do waitQSem sem cwd <- getCurrentDirectory when startClean $ removeDirectoryRecursiveSafe dir createDirectoryIfMissing True dir setCurrentDirectory dir return cwd after cwd = do setCurrentDirectory cwd signalQSem sem removeDirectoryRecursiveSafe p = doesDirectoryExist p >>= flip when (removeDirectoryRecursive p) snap-0.14.0.6/test/suite/TestSuite.hs0000644000000000000000000001217312552604453015476 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where ------------------------------------------------------------------------------ import Control.Concurrent import Control.Exception import Control.Monad import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import Network.Http.Client import Prelude hiding (catch) import Snap.Http.Server.Config import Snap.Snaplet import System.IO import System.Posix.Process import System.Posix.Signals import System.Posix.Types import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) ------------------------------------------------------------------------------ import Blackbox.App import qualified Blackbox.Tests import Snap.Http.Server (simpleHttpServe) import qualified Snap.Snaplet.Internal.Lensed.Tests import qualified Snap.Snaplet.Internal.LensT.Tests import qualified Snap.Snaplet.Internal.RST.Tests import qualified Snap.Snaplet.Internal.Tests import qualified Snap.Snaplet.Auth.Tests import qualified Snap.Snaplet.Test.Tests import Snap.TestCommon import SafeCWD ------------------------------------------------------------------------------ main :: IO () main = do Blackbox.Tests.remove "non-cabal-appdir/snaplets/heist/templates/bad.tpl" Blackbox.Tests.remove "non-cabal-appdir/snaplets/heist/templates/good.tpl" Blackbox.Tests.removeDir "non-cabal-appdir/snaplets/foosnaplet" (tid, mvar) <- inDir False "non-cabal-appdir" startServer defaultMain [tests] `finally` killThread tid putStrLn "waiting for termination mvar" takeMVar mvar where tests = mutuallyExclusive $ testGroup "snap" [ internalServerTests , Snap.Snaplet.Auth.Tests.tests , Snap.Snaplet.Test.Tests.tests , testDefault , testBarebones , testTutorial ] ------------------------------------------------------------------------------ internalServerTests :: Test internalServerTests = mutuallyExclusive $ testGroup "internal server tests" [ Blackbox.Tests.tests , Snap.Snaplet.Internal.Lensed.Tests.tests , Snap.Snaplet.Internal.LensT.Tests.tests , Snap.Snaplet.Internal.RST.Tests.tests , Snap.Snaplet.Internal.Tests.tests ] ------------------------------------------------------------------------------ startServer :: IO (ThreadId, MVar ()) startServer = do mvar <- newEmptyMVar t <- forkIO $ serve mvar (setPort 9753 defaultConfig) app threadDelay $ 2*10^(6::Int) return (t, mvar) where serve mvar config initializer = flip finally (putMVar mvar ()) $ handle handleErr $ do hPutStrLn stderr "initializing snaplet" (_, handler, doCleanup) <- runSnaplet Nothing initializer flip finally doCleanup $ do (conf, site) <- combineConfig config handler hPutStrLn stderr "bringing up server" simpleHttpServe conf site hPutStrLn stderr "server killed" handleErr :: SomeException -> IO () handleErr e = hPutStrLn stderr $ "startServer exception: " ++ show e ------------------------------------------------------------------------------ testBarebones :: Test testBarebones = testCase "snap/barebones" go where go = testGeneratedProject "barebonesTest" "barebones" "--force-reinstalls" port testIt port = 9990 :: Int testIt = do body <- get (S.pack $ "http://127.0.0.1:"++(show port)) concatHandler assertEqual "server not up" "hello world" body ------------------------------------------------------------------------------ testDefault :: Test testDefault = testCase "snap/default" go where go = testGeneratedProject "defaultTest" "" "--force-reinstalls" port testIt port = 9991 :: Int testIt = do body <- get (S.pack $ "http://127.0.0.1:"++(show port)) concatHandler assertBool "response contains phrase 'Snap Example App Login'" $ "Snap Example App Login" `S.isInfixOf` body ------------------------------------------------------------------------------ testTutorial :: Test testTutorial = testCase "snap/tutorial" go where go = testGeneratedProject "tutorialTest" "tutorial" "--force-reinstalls" port testIt port = 9992 :: Int testIt = do body <- get (S.pack $ "http://127.0.0.1:"++(show port)++"/hello") concatHandler assertEqual "server not up" "hello world" body snap-0.14.0.6/test/suite/Blackbox/0000755000000000000000000000000012552604453014732 5ustar0000000000000000snap-0.14.0.6/test/suite/Blackbox/App.hs0000644000000000000000000000757712552604453016026 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Blackbox.App where ------------------------------------------------------------------------------ import Prelude hiding (lookup) ------------------------------------------------------------------------------ import Control.Applicative import Control.Lens import Control.Monad.Trans import Data.Maybe import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Configurator import Snap.Core import Snap.Util.FileServe ------------------------------------------------------------------------------ import Snap.Snaplet import Snap.Snaplet.Heist import qualified Snap.Snaplet.HeistNoClass as HNC import Heist import Heist.Interpreted ------------------------------------------------------------------------------ import Blackbox.Common import Blackbox.BarSnaplet import Blackbox.FooSnaplet import Blackbox.EmbeddedSnaplet import Blackbox.Types import Snap.Snaplet.Session import Snap.Snaplet.Session.Backends.CookieSession -------------------- -- THE SNAPLET -- -------------------- ------------------------------------------------------------------------------ app :: SnapletInit App App app = makeSnaplet "app" "Test application" Nothing $ do hs <- nestSnaplet "heist" heist $ heistInit "templates" fs <- nestSnaplet "foo" foo $ fooInit hs bs <- nestSnaplet "" bar $ nameSnaplet "baz" $ barInit hs foo sm <- nestSnaplet "session" session $ initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60)) ns <- embedSnaplet "embed" embedded embeddedInit _lens <- getLens let splices = do "appsplice" ## textSplice "contents of the app splice" "appconfig" ## shConfigSplice _lens addConfig hs $ mempty & scInterpretedSplices .~ splices addRoutes [ ("/hello", writeText "hello world") , ("/routeWithSplice", routeWithSplice) , ("/routeWithConfig", routeWithConfig) , ("/public", serveDirectory "public") , ("/sessionDemo", sessionDemo) , ("/sessionTest", sessionTest) ] wrapSite (<|> heistServe) return $ App hs (over snapletValue fooMod fs) bs sm ns ------------------------------------------------------------------------------- routeWithSplice :: Handler App App () routeWithSplice = do str <- with foo getFooField writeText $ T.pack $ "routeWithSplice: "++str ------------------------------------------------------------------------------ routeWithConfig :: Handler App App () routeWithConfig = do cfg <- getSnapletUserConfig val <- liftIO $ lookup cfg "topConfigField" writeText $ "routeWithConfig: " `T.append` fromJust val ------------------------------------------------------------------------------ sessionDemo :: Handler App App () sessionDemo = withSession session $ do with session $ do curVal <- getFromSession "foo" case curVal of Nothing -> setInSession "foo" "bar" Just _ -> return () list <- with session $ (T.pack . show) `fmap` sessionToList csrf <- with session $ (T.pack . show) `fmap` csrfToken HNC.renderWithSplices heist "session" $ do "session" ## textSplice list "csrf" ## textSplice csrf ------------------------------------------------------------------------------ sessionTest :: Handler App App () sessionTest = withSession session $ do q <- getParam "q" val <- case q of Just x -> do let x' = T.decodeUtf8 x with session $ setInSession "test" x' return x' Nothing -> fromMaybe "" `fmap` with session (getFromSession "test") writeText val fooMod :: FooSnaplet -> FooSnaplet fooMod f = f { fooField = fooField f ++ "z" } snap-0.14.0.6/test/suite/Blackbox/BarSnaplet.hs0000644000000000000000000000331612552604453017324 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} module Blackbox.BarSnaplet where import Prelude hiding (lookup) import Control.Lens import Control.Monad.State import qualified Data.ByteString as B import Data.Configurator import Data.Maybe import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Core import Heist import Heist.Interpreted import Blackbox.Common import Blackbox.FooSnaplet data BarSnaplet b = BarSnaplet { _barField :: String , fooLens :: SnapletLens b FooSnaplet } makeLenses ''BarSnaplet barsplice :: Splices (SnapletISplice b) barsplice = "barsplice" ## textSplice "contents of the bar splice" barInit :: HasHeist b => Snaplet (Heist b) -> SnapletLens b FooSnaplet -> SnapletInit b (BarSnaplet b) barInit h l = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do config <- getSnapletUserConfig addTemplates h "" rootUrl <- getSnapletRootURL _lens <- getLens addRoutes [("barconfig", liftIO (lookup config "barSnapletField") >>= writeLBS . fromJust) ,("barrooturl", writeBS $ "url" `B.append` rootUrl) ,("bazpage2", renderWithSplices "bazpage" barsplice) ,("bazpage3", heistServeSingle "bazpage") ,("bazpage4", renderAs "text/html" "bazpage") ,("bazpage5", renderWithSplices "bazpage" ("barsplice" ## shConfigSplice _lens)) ,("bazbadpage", heistServeSingle "cpyga") ,("bar/handlerConfig", handlerConfig) ] return $ BarSnaplet "bar snaplet data string" l snap-0.14.0.6/test/suite/Blackbox/Common.hs0000644000000000000000000000127112552604453016517 0ustar0000000000000000module Blackbox.Common where import Control.Lens import Control.Monad.Trans import qualified Data.Text as T import Snap.Core import Snap.Snaplet import Snap.Snaplet.Heist import Heist.Interpreted genericConfigString :: (MonadSnaplet m, Monad (m b v)) => m b v T.Text genericConfigString = do a <- getSnapletAncestry b <- getSnapletFilePath c <- getSnapletName d <- getSnapletDescription e <- getSnapletRootURL return $ T.pack $ show (a,b,c,d,e) handlerConfig :: Handler b v () handlerConfig = writeText =<< genericConfigString shConfigSplice :: SnapletLens (Snaplet b) v -> SnapletISplice b shConfigSplice _lens = textSplice =<< lift (with' _lens genericConfigString) snap-0.14.0.6/test/suite/Blackbox/EmbeddedSnaplet.hs0000644000000000000000000000352312552604453020311 0ustar0000000000000000{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} module Blackbox.EmbeddedSnaplet where import Prelude hiding ((.)) import Control.Lens import Control.Monad.State import qualified Data.Text as T import System.FilePath.Posix import Snap.Snaplet import Snap.Snaplet.Heist import Heist import Heist.Interpreted -- If we universally quantify EmbeddedSnaplet to get rid of the type parameter -- mkLabels throws an error "Can't reify a GADT data constructor" data EmbeddedSnaplet = EmbeddedSnaplet { _embeddedHeist :: Snaplet (Heist EmbeddedSnaplet) , _embeddedVal :: Int } makeLenses ''EmbeddedSnaplet instance HasHeist EmbeddedSnaplet where heistLens = subSnaplet embeddedHeist embeddedInit :: SnapletInit EmbeddedSnaplet EmbeddedSnaplet embeddedInit = makeSnaplet "embedded" "embedded snaplet" Nothing $ do hs <- nestSnaplet "heist" embeddedHeist $ heistInit "templates" -- This is the implementation of addTemplates, but we do it here manually -- to test coverage for addTemplatesAt. snapletPath <- getSnapletFilePath addTemplatesAt hs "onemoredir" (snapletPath "extra-templates") embeddedLens <- getLens addRoutes [("aoeuhtns", withSplices ("asplice" ## embeddedSplice embeddedLens) (render "embeddedpage")) ] return $ EmbeddedSnaplet hs 42 embeddedSplice :: (SnapletLens (Snaplet b) EmbeddedSnaplet) -> SnapletISplice b embeddedSplice embeddedLens = do val <- lift $ with' embeddedLens $ gets _embeddedVal textSplice $ T.pack $ "splice value" ++ (show val) snap-0.14.0.6/test/suite/Blackbox/FooSnaplet.hs0000644000000000000000000000273412552604453017346 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} module Blackbox.FooSnaplet where import Prelude hiding (lookup) import Control.Lens import Control.Monad.State import Data.Configurator import Data.Maybe import Data.Monoid import qualified Data.Text as T import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Core import Heist import Heist.Interpreted import Blackbox.Common data FooSnaplet = FooSnaplet { fooField :: String } fooInit :: HasHeist b => Snaplet (Heist b) -> SnapletInit b FooSnaplet fooInit h = makeSnaplet "foosnaplet" "A demonstration snaplet called foo." (Just $ return "../foosnaplet") $ do config <- getSnapletUserConfig addTemplates h "" rootUrl <- getSnapletRootURL fp <- getSnapletFilePath name <- getSnapletName _lens <- getLens let splices = do "foosplice" ## textSplice "contents of the foo splice" "fooconfig" ## shConfigSplice _lens addConfig h $ mempty & scInterpretedSplices .~ splices addRoutes [("fooConfig", liftIO (lookup config "fooSnapletField") >>= writeLBS . fromJust) ,("fooRootUrl", writeBS rootUrl) ,("fooSnapletName", writeText $ fromMaybe "empty snaplet name" name) ,("fooFilePath", writeText $ T.pack fp) ,("handlerConfig", handlerConfig) ] return $ FooSnaplet "foo snaplet data string" getFooField :: Handler b FooSnaplet String getFooField = gets fooField snap-0.14.0.6/test/suite/Blackbox/Tests.hs0000644000000000000000000003216512552604453016377 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Blackbox.Tests ( tests , remove , removeDir ) where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as Builder import Control.Exception (catch, throwIO) import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.Monoid import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as T import Network.Http.Client import Prelude hiding (catch) import System.Directory import System.FilePath import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ testServer :: String testServer = "http://127.0.0.1" ------------------------------------------------------------------------------ testPort :: String testPort = "9753" ------------------------------------------------------------------------------ -- | The server uri, without the leading slash. testServerUri :: String testServerUri = testServer ++ ":" ++ testPort ------------------------------------------------------------------------------ -- | The server url, with the leading slash. testServerUrl :: String testServerUrl = testServerUri ++ "/" -------------------- -- TEST LOADER -- -------------------- ------------------------------------------------------------------------------ tests :: Test tests = testGroup "non-cabal-tests" [ requestTest "hello" "hello world" , requestTest "index" "index page\n" , requestTest "" "index page\n" , requestTest "splicepage" "splice page contents of the app splice\n" , requestTest "routeWithSplice" "routeWithSplice: foo snaplet data stringz" , requestTest "routeWithConfig" "routeWithConfig: topConfigValue" , requestTest "foo/foopage" "foo template page\n" , requestTest "foo/fooConfig" "fooValue" , requestTest "foo/fooRootUrl" "foo" , requestTest "barconfig" "barValue" , requestTest "bazpage" "baz template page \n" , requestTest "bazpage2" "baz template page contents of the bar splice\n" , requestTest "bazpage3" "baz template page \n" , requestTest "bazpage4" "baz template page \n" , requestTest "barrooturl" "url" , requestExpectingError "bazbadpage" 500 "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found." , requestTest "foo/fooSnapletName" "foosnaplet" , fooConfigPathTest -- Test the embedded snaplet , requestTest "embed/heist/embeddedpage" "embedded snaplet page \n" , requestTest "embed/aoeuhtns" "embedded snaplet page splice value42\n" , requestTest "embed/heist/onemoredir/extra" "This is an extra template\n" -- This set of tests highlights the differences in the behavior of the -- get... functions from MonadSnaplet. , fooHandlerConfigTest , barHandlerConfigTest , bazpage5Test , bazConfigTest , requestTest "sessionDemo" "[(\"foo\",\"bar\")]\n" , reloadTest ] ------------------------------------------------------------------------------ testName :: String -> String testName uri = "internal/" ++ uri ------------------------------------------------------------------------------ requestTest :: String -> Text -> Test requestTest url desired = testCase (testName url) $ requestTest' url desired ------------------------------------------------------------------------------ requestTest' :: String -> Text -> IO () requestTest' url desired = do actual <- get (S.pack $ testServerUrl ++ url) concatHandler assertEqual url desired (T.decodeUtf8 $ L.fromChunks [actual]) ------------------------------------------------------------------------------ requestExpectingError :: String -> Int -> Text -> Test requestExpectingError url status desired = testCase (testName url) $ requestExpectingError' url status desired ------------------------------------------------------------------------------ requestExpectingError' :: String -> Int -> Text -> IO () requestExpectingError' url status desired = do let fullUrl = testServerUrl ++ url get (S.pack fullUrl) $ \resp is -> do assertEqual ("Status code: "++fullUrl) status (getStatusCode resp) res <- concatHandler resp is assertEqual fullUrl desired (T.decodeUtf8 $ L.fromChunks [res]) ------------------------------------------------------------------------------ fooConfigPathTest :: Test fooConfigPathTest = testCase (testName "foo/fooFilePath") $ do b <- liftM L.unpack $ grab "/foo/fooFilePath" assertRelativelyTheSame b "non-cabal-appdir/snaplets/foosnaplet" ------------------------------------------------------------------------------ assertRelativelyTheSame :: FilePath -> FilePath -> IO () assertRelativelyTheSame p expected = do b <- makeRelativeToCurrentDirectory p assertEqual ("expected " ++ expected) expected b ------------------------------------------------------------------------------ grab :: MonadIO m => String -> m L.ByteString grab path = liftIO $ liftM (L.fromChunks . (:[])) $ get (S.pack $ testServerUri ++ path) concatHandler ------------------------------------------------------------------------------ testWithCwd :: String -> (String -> L.ByteString -> Assertion) -> Test testWithCwd uri f = testCase (testName uri) $ testWithCwd' uri f ------------------------------------------------------------------------------ testWithCwd' :: String -> (String -> L.ByteString -> Assertion) -> Assertion testWithCwd' uri f = do b <- grab slashUri cwd <- getCurrentDirectory f cwd b where slashUri = '/' : uri ------------------------------------------------------------------------------ fooHandlerConfigTest :: Test fooHandlerConfigTest = testWithCwd "foo/handlerConfig" $ \cwd b -> do let response = L.fromChunks [ "([\"app\"],\"" , S.pack cwd , "/non-cabal-appdir/snaplets/foosnaplet\"," , "Just \"foosnaplet\",\"A demonstration " , "snaplet called foo.\",\"foo\")" ] assertEqual "" response b ------------------------------------------------------------------------------ barHandlerConfigTest :: Test barHandlerConfigTest = testWithCwd "bar/handlerConfig" $ \cwd b -> do let response = L.fromChunks [ "([\"app\"],\"" , S.pack cwd , "/non-cabal-appdir/snaplets/baz\"," , "Just \"baz\",\"An example snaplet called " , "bar.\",\"\")" ] assertEqual "" response b ------------------------------------------------------------------------------ -- bazpage5 uses barsplice bound by renderWithSplices at request time bazpage5Test :: Test bazpage5Test = testWithCwd "bazpage5" $ \cwd b -> do let response = L.fromChunks [ "baz template page ([\"app\"],\"" , S.pack cwd , "/non-cabal-appdir/snaplets/baz\"," , "Just \"baz\",\"An example snaplet called " , "bar.\",\"\")\n" ] assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b) ------------------------------------------------------------------------------ -- bazconfig uses two splices, appconfig and fooconfig. appconfig is bound with -- the non type class version of addSplices in the main app initializer. -- fooconfig is bound by addSplices in fooInit. bazConfigTest :: Test bazConfigTest = testWithCwd "bazconfig" $ \cwd b -> do let response = L.fromChunks [ "baz config page ([],\"" , S.pack cwd , "/non-cabal-appdir\",Just \"app\"," , "\"Test application\",\"\") " , "([\"app\"],\"" , S.pack cwd , "/non-cabal-appdir/snaplets/foosnaplet\"," , "Just \"foosnaplet\",\"A demonstration snaplet " , "called foo.\",\"foo\")\n" ] assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b) ------------------------------------------------------------------------------ expect404 :: String -> IO () expect404 url = do get (S.pack $ testServerUrl ++ url) $ \resp i -> do case getStatusCode resp of 404 -> return () _ -> assertFailure "expected 404" ------------------------------------------------------------------------------ request404Test :: String -> Test request404Test url = testCase (testName url) $ expect404 url remove :: FilePath -> IO () remove f = do exists <- doesFileExist f when exists $ removeFile f removeDir :: FilePath -> IO () removeDir d = do exists <- doesDirectoryExist d when exists $ removeDirectoryRecursive "non-cabal-appdir/snaplets/foosnaplet" ------------------------------------------------------------------------------ reloadTest :: Test reloadTest = testCase "internal/reload-test" $ do let goodTplOrig = "non-cabal-appdir" "good.tpl" let badTplOrig = "non-cabal-appdir" "bad.tpl" let goodTplNew = "non-cabal-appdir" "snaplets" "heist" "templates" "good.tpl" let badTplNew = "non-cabal-appdir" "snaplets" "heist" "templates" "bad.tpl" goodExists <- doesFileExist goodTplNew badExists <- doesFileExist badTplNew assertBool "good.tpl exists" (not goodExists) assertBool "bad.tpl exists" (not badExists) expect404 "bad" copyFile badTplOrig badTplNew expect404 "good" expect404 "bad" testWithCwd' "admin/reload" $ \cwd' b -> do let cwd = S.pack cwd' let response = T.concat [ "Error reloading site!\n\nInitializer " , "threw an exception...\n" , T.pack cwd' , "/non-cabal-appdir/snaplets/heist" , "/templates/bad.tpl \"" , T.pack cwd' , "/non-cabal-appdir/snaplets/heist/templates" , "/bad.tpl\" (line 2, column 1):\nunexpected " , "end of input\nexpecting \"=\", \"/\" or " , "\">\"\n\n...but before it died it generated " , "the following output:\nInitializing app @ /\n" , "Initializing heist @ /heist\n\n" ] assertEqual "admin/reload" response (T.decodeUtf8 b) remove badTplNew copyFile goodTplOrig goodTplNew testWithCwd' "admin/reload" $ \cwd' b -> do let cwd = S.pack cwd' let response = L.fromChunks [ "Initializing app @ /\n" , "Initializing heist @ /heist\n" , "...loaded 5 templates from " , cwd , "/non-cabal-appdir/snaplets/heist/templates\n" , "Initializing foosnaplet @ /foo\n" , "...adding 1 templates from " , cwd , "/non-cabal-appdir/snaplets/foosnaplet" , "/templates with route prefix foo/\n" , "Initializing baz @ /\n" , "...adding 2 templates from " , cwd , "/non-cabal-appdir/snaplets/baz/templates " , "with route prefix /\n" , "Initializing CookieSession @ /session\n" , "Initializing embedded @ /\n" , "Initializing heist @ /heist\n" , "...loaded 1 templates from " , cwd , "/non-cabal-appdir/snaplets/embedded" , "/snaplets/heist/templates\n" , "...adding 1 templates from " , cwd , "/non-cabal-appdir/snaplets/embedded" , "/extra-templates with route prefix " , "onemoredir/\n" , "Site successfully reloaded.\n" ] assertEqual "admin/reload" response b requestTest' "good" "Good template\n" snap-0.14.0.6/test/suite/Blackbox/Types.hs0000644000000000000000000000131212552604453016367 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Blackbox.Types where import Control.Lens import Snap.Snaplet import Snap.Snaplet.Heist import Blackbox.FooSnaplet import Blackbox.BarSnaplet import Blackbox.EmbeddedSnaplet import Snap.Snaplet.Session data App = App { _heist :: Snaplet (Heist App) , _foo :: Snaplet FooSnaplet , _bar :: Snaplet (BarSnaplet App) , _session :: Snaplet SessionManager , _embedded :: Snaplet EmbeddedSnaplet } makeLenses ''App instance HasHeist App where heistLens = subSnaplet heist snap-0.14.0.6/test/suite/Snap/0000755000000000000000000000000012552604453014106 5ustar0000000000000000snap-0.14.0.6/test/suite/Snap/TestCommon.hs0000644000000000000000000001442212552604453016535 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Snap.TestCommon where ------------------------------------------------------------------------------ import Control.Concurrent ( threadDelay ) import Control.Exception ( ErrorCall(..) , SomeException , bracket , catch , throwIO ) import Control.Monad ( forM_ ) import Data.Maybe ( fromMaybe ) import Data.Monoid ( First(..), mconcat ) import Prelude hiding ( catch ) import System.Cmd ( system ) import System.Directory ( doesFileExist , getCurrentDirectory , findExecutable , removeFile ) import System.Environment ( getEnv ) import System.Exit ( ExitCode(..) ) import System.FilePath ( joinPath, splitPath, () ) import System.FilePath.Glob ( compile, globDir1 ) import System.Process ( runCommand , terminateProcess , waitForProcess ) ------------------------------------------------------------------------------ import SafeCWD ------------------------------------------------------------------------------ testGeneratedProject :: String -- ^ project name and directory -> String -- ^ arguments to @snap init@ -> String -- ^ arguments to @cabal install@ -> Int -- ^ port to run http server on -> IO () -- ^ action to run when the server goes up -> IO () testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort testAction = do cwd <- getCurrentDirectory -------------------------------------------------------------------------- let segments = reverse $ splitPath cwd projectPath = cwd "test-snap-exe" projName snapRoot = joinPath $ reverse $ drop 1 segments snapRepos = joinPath $ reverse $ drop 2 segments sandbox = cwd "test-cabal-dev" cabalDevArgs = "-s " ++ sandbox args = cabalDevArgs ++ " --reinstall " ++ cabalInstallArgs ---------------------------------------------------------------------- initialize = do snapExe <- findSnap systemOrDie $ snapExe ++ " init " ++ snapInitArgs snapCoreSrc <- fromEnv "SNAP_CORE_SRC" $ snapRepos "snap-core" snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $ snapRepos "snap-server" xmlhtmlSrc <- fromEnv "XMLHTML_SRC" $ snapRepos "xmlhtml" heistSrc <- fromEnv "HEIST_SRC" $ snapRepos "heist" dynLoaderSrc <- fromEnv "DYNAMIC_LOADER_SRC" $ snapRepos "snap-loader-dynamic" staticLoaderSrc <- fromEnv "STATIC_LOADER_SRC" $ snapRepos "snap-loader-static" let snapSrc = snapRoot forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap" , "snap-loader-static", "snap-loader-dynamic"] (pkgCleanUp sandbox) forM_ [ snapCoreSrc, snapServerSrc, xmlhtmlSrc, heistSrc , snapSrc, staticLoaderSrc, dynLoaderSrc] $ \s -> systemOrDie $ concat [ "cabal-dev " , cabalDevArgs , " add-source " , s ] systemOrDie $ "cabal-dev install " ++ args let cmd = ("." "dist" "build" projName projName) ++ " -p " ++ show httpPort putStrLn $ "Running \"" ++ cmd ++ "\"" pHandle <- runCommand cmd waitABit return pHandle ---------------------------------------------------------------------- findSnap = do home <- fromEnv "HOME" "." p1 <- gimmeIfExists $ snapRoot "dist" "build" "snap" "snap" p2 <- gimmeIfExists $ home ".cabal" "bin" "snap" p3 <- findExecutable "snap" return $ fromMaybe (error "couldn't find snap executable") (getFirst $ mconcat $ map First [p1,p2,p3]) -------------------------------------------------------------------------- putStrLn $ "Changing directory to " ++ projectPath inDir True projectPath $ bracket initialize cleanup (const testAction) removeDirectoryRecursiveSafe projectPath where -------------------------------------------------------------------------- fromEnv name def = do r <- getEnv name `catch` \(_::SomeException) -> return "" if r == "" then return def else return r -------------------------------------------------------------------------- cleanup pHandle = do terminateProcess pHandle waitForProcess pHandle -------------------------------------------------------------------------- waitABit = threadDelay $ 2*10^(6::Int) -------------------------------------------------------------------------- pkgCleanUp d pkg = do paths <- globDir1 (compile $ "packages*conf/" ++ pkg ++ "-*") d forM_ paths $ \x -> rm x `catch` \(_::SomeException) -> return () where rm x = do putStrLn $ "removing " ++ x removeFile x -------------------------------------------------------------------------- gimmeIfExists p = do b <- doesFileExist p if b then return (Just p) else return Nothing ------------------------------------------------------------------------------ systemOrDie :: String -> IO () systemOrDie s = do putStrLn $ "Running \"" ++ s ++ "\"" system s >>= check where check ExitSuccess = return () check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'" snap-0.14.0.6/test/suite/Snap/Snaplet/0000755000000000000000000000000012552604453015514 5ustar0000000000000000snap-0.14.0.6/test/suite/Snap/Snaplet/Internal/0000755000000000000000000000000012552604453017270 5ustar0000000000000000snap-0.14.0.6/test/suite/Snap/Snaplet/Internal/Tests.hs0000644000000000000000000001046512552604453020734 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} module Snap.Snaplet.Internal.Tests ( tests, initTest ) where ------------------------------------------------------------------------------ import Control.Lens import Control.Monad import Control.Monad.Trans import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.List import Data.Text (Text) import Prelude hiding (catch, (.)) import System.Directory import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.SmallCheck import Test.HUnit hiding (Test, path) import Test.SmallCheck ------------------------------------------------------------------------------ import Snap.Snaplet.Internal.Initializer import Snap.Snaplet.Internal.Types --------------------------------- -- TODO: this module is a mess -- --------------------------------- ------------------------------------------------------------------------------ data Foo = Foo Int data Bar = Bar Int data App = App { _foo :: Snaplet Foo , _bar :: Snaplet Bar } makeLenses ''App --showConfig :: SnapletConfig -> IO () --showConfig c = do -- putStrLn "SnapletConfig:" -- print $ _scAncestry c -- print $ _scFilePath c -- print $ _scId c -- print $ _scDescription c -- print $ _scRouteContext c -- putStrLn "" ------------------------------------------------------------------------------ assertGet :: (MonadIO m, Show a, Eq a) => String -> m a -> a -> m () assertGet name getter val = do v <- getter liftIO $ assertEqual name val v ------------------------------------------------------------------------------ configAssertions :: (MonadSnaplet m, MonadIO (m b v)) => [Char] -> ([Text], FilePath, Maybe Text, Text, ByteString) -> m b v () configAssertions prefix (a,f,n,d,r) = do assertGet (prefix ++ "ancestry" ) getSnapletAncestry a assertGet (prefix ++ "file path" ) getSnapletFilePath f assertGet (prefix ++ "name" ) getSnapletName n assertGet (prefix ++ "description" ) getSnapletDescription d assertGet (prefix ++ "route context" ) getSnapletRootURL r ------------------------------------------------------------------------------ appInit :: SnapletInit App App appInit = makeSnaplet "app" "Test application" Nothing $ do cwd <- liftIO getCurrentDirectory configAssertions "root " ([], cwd, Just "app", "Test application", "") assertGet "environment" getEnvironment "devel" f <- nestSnaplet "foo" foo $ fooInit b <- nestSnaplet "bar" bar $ barInit return $ App f b ------------------------------------------------------------------------------ fooInit :: SnapletInit b Foo fooInit = makeSnaplet "foo" "Foo Snaplet" Nothing $ do cwd <- liftIO getCurrentDirectory let dir = cwd ++ "/snaplets/foo" configAssertions "foo " (["app"], dir, Just "foo", "Foo Snaplet", "foo") return $ Foo 42 ------------------------------------------------------------------------------ barInit :: SnapletInit b Bar barInit = makeSnaplet "bar" "Bar Snaplet" Nothing $ do cwd <- liftIO getCurrentDirectory let dir = cwd ++ "/snaplets/bar" configAssertions "bar " (["app"], dir, Just "bar", "Bar Snaplet", "bar") return $ Bar 2 ------------------------------------------------------------------------------ initTest :: IO () initTest = do (out,_,_) <- runSnaplet Nothing appInit -- note from gdc: wtf? if out == "aoeu" then putStrLn "Something really strange" else return () ------------------------------------------------------------------------------ tests :: Test tests = testGroup "Snap.Snaplet.Internal" [ testCase "initializer tests" initTest , testProperty "buildPath generates no double slashes" doubleSlashes ] --doubleSlashes :: Monad m => [String] -> Property m doubleSlashes arrStr = noSlashes ==> not (B.isInfixOf "//" $ buildPath arr) where arr = map B.pack arrStr noSlashes = not $ or $ map (B.elem '/') arr snap-0.14.0.6/test/suite/Snap/Snaplet/Internal/Lensed/0000755000000000000000000000000012552604453020502 5ustar0000000000000000snap-0.14.0.6/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs0000644000000000000000000000657412552604453022154 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Snap.Snaplet.Internal.Lensed.Tests (tests) where import Control.Applicative import Control.Category import Control.Exception import Control.Lens import Control.Monad.State.Strict import Prelude hiding (catch, (.)) import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) ------------------------------------------------------------------------------ import Snap.Snaplet.Internal.Lensed ------------------------------------------------------------------------------ data TestType = TestType { _int0 :: Int , _sub :: TestSubType } deriving (Show) data TestSubType = TestSubType { _sub0 :: Int , _sub1 :: Int , _bot :: TestBotType } deriving (Show) data TestBotType = TestBotType { _bot0 :: Int } deriving (Show) makeLenses ''TestType makeLenses ''TestSubType makeLenses ''TestBotType ------------------------------------------------------------------------------ defaultState :: TestType defaultState = TestType 1 $ TestSubType 2 999 $ TestBotType 3 ------------------------------------------------------------------------------ tests = testGroup "Snap.Snaplet.Internal.Lensed" [ testfmap , testApplicative , testMonadState ] ------------------------------------------------------------------------------ testfmap :: Test testfmap = testCase "lensed/fmap" $ do x <- evalStateT (lensedAsState (fmap (*2) three) (sub . bot)) defaultState assertEqual "fmap" 6 x (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState assertEqual "fmap2" 12 y assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s' return () where three :: Lensed TestType TestBotType IO Int three = return 3 twiddle = do modify $ \(TestBotType x) -> TestBotType (x+10) fmap (+9) three ------------------------------------------------------------------------------ testApplicative :: Test testApplicative = testCase "lensed/applicative" $ do x <- evalStateT (lensedAsState (pure (*2) <*> three) (sub . bot)) defaultState assertEqual "fmap" 6 x (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState assertEqual "fmap2" (12::Int) y assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s' return () where three :: Lensed TestType TestBotType IO Int three = pure 3 twiddle = do modify $ \(TestBotType x) -> TestBotType (x+10) pure [] *> (pure (+9) <*> three) <* pure [] ------------------------------------------------------------------------------ testMonadState :: Test testMonadState = testCase "lens/MonadState" $ do s <- execStateT (lensedAsState go (sub . bot . bot0)) defaultState assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s assertEqual "sub0" 3 $ _sub0 $ _sub s assertEqual "sub1" 1000 $ _sub1 $ _sub s where go :: Lensed TestType Int IO () go = do modify (*2) modify (+3) withTop sub go' go' :: Lensed TestType TestSubType IO () go' = do a <- with sub0 get with sub0 $ put $ a+1 embed sub1 go'' go'' :: Lensed TestSubType Int IO () go'' = modify (+1) eat :: SomeException -> IO () eat _ = return () qqq = defaultMainWithArgs [tests] ["--plain"] `catch` eat snap-0.14.0.6/test/suite/Snap/Snaplet/Internal/LensT/0000755000000000000000000000000012552604453020315 5ustar0000000000000000snap-0.14.0.6/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs0000644000000000000000000000673312552604453021764 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Snap.Snaplet.Internal.LensT.Tests (tests) where import Control.Lens import Control.Applicative import Control.Category import Control.Monad.Identity import Control.Monad.State.Strict import Prelude hiding (catch, (.)) import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) ------------------------------------------------------------------------------ import Snap.Snaplet.Internal.LensT ------------------------------------------------------------------------------ data TestType = TestType { _int0 :: Int , _sub :: TestSubType } deriving (Show) data TestSubType = TestSubType { _sub0 :: Int , _sub1 :: Int , _bot :: TestBotType } deriving (Show) data TestBotType = TestBotType { _bot0 :: Int } deriving (Show) makeLenses ''TestType makeLenses ''TestSubType makeLenses ''TestBotType ------------------------------------------------------------------------------ defaultState :: TestType defaultState = TestType 1 $ TestSubType 2 999 $ TestBotType 3 ------------------------------------------------------------------------------ tests :: Test tests = testGroup "Snap.Snaplet.Internal.LensT" [ testfmap , testApplicative , testMonadState ] ------------------------------------------------------------------------------ testfmap :: Test testfmap = testCase "lensed/fmap" $ do -- x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState let x = fst $ runIdentity (runLensT (fmap (*2) three) (sub . bot) defaultState) assertEqual "fmap" 6 x let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState) assertEqual "fmap2" (12 :: Int) y assertEqual "lens" (13 :: Int) $ _bot0 $ _bot $ _sub s' return () where -- three :: LensT TestType TestBotType IO Int three = return 3 twiddle = do modify $ \(TestBotType x) -> TestBotType (x+10) fmap (+9) three ------------------------------------------------------------------------------ testApplicative :: Test testApplicative = testCase "lensed/applicative" $ do -- x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState let x = fst $ runIdentity (runLensT (pure (*2) <*> three) (sub . bot) defaultState) assertEqual "fmap" 6 x let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState) assertEqual "fmap2" (12::Int) y assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s' return () where -- three :: LensT TestType TestBotType IO Int three = pure 3 twiddle = do modify $ \(TestBotType x) -> TestBotType (x+10) pure [] *> (pure (+9) <*> three) <* pure [] ------------------------------------------------------------------------------ testMonadState :: Test testMonadState = testCase "lens/MonadState" $ do -- s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState let s = snd $ runIdentity (runLensT go (sub . bot . bot0) defaultState) assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s assertEqual "sub0" 3 $ _sub0 $ _sub s assertEqual "sub1" 999 $ _sub1 $ _sub s where -- go :: LensT TestType Int IO () go = do modify (*2) modify (+3) withTop sub go' -- go' :: LensT TestType TestSubType IO () go' = do a <- with sub0 get with sub0 $ put $ a+1 snap-0.14.0.6/test/suite/Snap/Snaplet/Internal/RST/0000755000000000000000000000000012552604453017740 5ustar0000000000000000snap-0.14.0.6/test/suite/Snap/Snaplet/Internal/RST/Tests.hs0000644000000000000000000000325112552604453021377 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} module Snap.Snaplet.Internal.RST.Tests ( tests ) where import Control.Applicative import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State import Prelude hiding (catch, (.)) import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import Test.HUnit hiding (Test, path) import Snap.Snaplet.Internal.RST tests :: Test tests = testGroup "Snap.Snaplet.Internal.RST" [ testExec , testEval , testFail , testAlternative ] testEval :: Test testEval = testProperty "RST/execRST" prop where prop x = runIdentity (evalRST m x undefined) == x m :: RST Int () Identity Int m = ask testExec :: Test testExec = testProperty "RST/execRST" prop where prop x = runIdentity (execRST m undefined x) == x m :: RST () Int Identity Int m = get testFail :: Test testFail = testCase "RST/fail" $ assertEqual "RST fail" rstFail Nothing testAlternative :: Test testAlternative = testCase "RST/Alternative" $ do assertEqual "Alternative instance" rstAlt (Just (5, 1)) assertEqual "Alternative instance" rstAlt2 (Just (5, 1)) addEnv :: Monad m => RST Int Int m () addEnv = do v <- ask modify (+v) rstAlt :: Maybe (Int, Int) rstAlt = runRST (addEnv >> (empty <|> (return 5))) 1 0 rstAlt2 :: Maybe (Int, Int) rstAlt2 = runRST (addEnv >> ((return 5) <|> empty)) 1 0 rstFail :: Maybe Int rstFail = evalRST (fail "foo") (0 :: Int) (0 :: Int)