snap-1.1.2.0/0000755000000000000000000000000000000000000010741 5ustar0000000000000000snap-1.1.2.0/.ghci0000755000000000000000000000004400000000000011655 0ustar0000000000000000:set -XOverloadedStrings :set -isrc snap-1.1.2.0/CONTRIBUTORS0000755000000000000000000000042100000000000012621 0ustar0000000000000000Ozgun Ataman Doug Beardsley Gregory Collins Carl Howells Chris Smith Jurriën Stutterheim Alfredo Di Napoli snap-1.1.2.0/LICENSE0000644000000000000000000000274500000000000011756 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-1.1.2.0/LICENSE0000755000000000000000000000274500000000000011761 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-1.1.2.0/README.SNAP.md0000755000000000000000000000227300000000000012767 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-1.1.2.0/README.md0000755000000000000000000000465300000000000012233 0ustar0000000000000000Snap Framework [![Hackage Status](https://img.shields.io/hackage/v/snap.svg)](https://hackage.haskell.org/package/snap) ============== [![Build Status](https://travis-ci.org/snapframework/snap.svg?branch=master)](https://travis-ci.org/snapframework/snap) Snap is a simple and fast web development framework and server written in Haskell. For more information about Snap, read the `README.SNAP.md` or visit the Snap project website at http://www.snapframework.com/. ## Library contents This is top-level project for the Snap Framework, which contains: * 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. The command-line utility `snap` for creating initial Snap applications used to be a part of this package. As of version 1.0, the snap command-line utility is no longer provided by this package. It is now provided by the package [`snap-templates`](https://github.com/snapframework/snap-templates). Building snap ============= After you clone the repository, change to the newly created snap directory and run git submodule update --init --recursive ./init-sandbox.sh cabal install (You may want to look at pull.sh or pullLatestMaster.sh.) This updates all the Snap Framework dependencies to the correct version, creates a sandbox, and installs everything. The snap library is built using [Cabal](http://www.haskell.org/cabal/) and [Hackage](http://hackage.haskell.org/packages/hackage.html). ## 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, run $ cabal clean $ cabal configure --enable-tests --enable-library-coverage $ cabal build $ cabal install --enable-tests From here you can invoke the testsuite by running: $ ./runTestsAndCoverage.sh The testsuite generates an `hpc` test coverage report in `dist/hpc`. ## Roadmap to Understanding Snaplets 1. Read `Tutorial.lhs` which is in the `project_template/tutorial/src` directory of the `snap-templates` package. 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-1.1.2.0/Setup.hs0000644000000000000000000000005700000000000012377 0ustar0000000000000000import Distribution.Simple main = defaultMain snap-1.1.2.0/design.md0000755000000000000000000001502400000000000012541 0ustar0000000000000000# Snaplet Design The Snaplet infrastructure was designed with three high-level design goals: * Request local state * Composability * Availability First, request local state means that snaplets should be able to define their own state that will be available during request processing. And that state should be mutable with scope local to the request. Composability means that applications and snaplets should be interchangeable, and you should be able to build them by gluing together other snaplets. Availability means that you should be able to access your application state without threading it manually through parameters. ## Handler Implementing the goal of request local state means that we need some kind of a Handler monad that will look roughly like a state transformer built on top of the Snap monad with the top level application data as the state. To implement composability we also need an additional type parameter that can be changed to match the scope of the current snaplet. We use the `withReader :: (r1 -> r2) -> Reader r2 a -> Reader r1 a` pattern to manage scope changes, but in order to make our state composably mutable, we need to enlist the help of lenses instead of accessor functions. This allows us to keep only the top level state and mutate the current context using the lens. The LensT monad is our implementation of this abstraction. It is a combination of ReaderT and StateT (our RST abstraction). Since the lens is not conceptually mutable in the same way as the actual state, it is stored in the reader environment. The state monad part is used for the top level state b, giving is the following newtype. newtype LensT b v s m a = LensT (RST (Lens b v) s m a) LensT comes with a (MonadReader (Lens b v)) instance for retrieving the lens and a (MonadState v) instance that uses the lens transparently to achieve stateful behavior with the type v. From here the definition of Handler is fairly natural: newtype Handler b v a = Handler (LensT (Snaplet b) (Snaplet v) (Snaplet b) Snap a) We use `LensT (Snaplet b) (Snaplet v)` instead of `LensT b (Snaplet v)` because it is desirable to be able to use the identity lens to construct a `Handler b b`. The only issue with this formulation is that the lens manipulation functions provided by LensT are not what the end user needs. The end user has a lens of type `Lens b (Snaplet v)` created by the `mkLabels` function. But LensT's withXYZ functions need `Lens (Snaplet b) (Snaplet v)` lenses. These can be derived easily by composing the user-supplied lens with the internal lens `Lens (Snaplet a) a` derived from the definition of the Snaplet data structure. NOTE: The above definition for Handler is no longer correct. We switched to a slightly more specialized monad formulation called Lensed that avoids traversal of the whole state hierarchy when the state is manipulated. Thanks to Edward Kmett for pointing this out and writing the code for us. ## Initializer The second important component of snaplets is initialization. This involves setting up the state used by the handlers as well as defining a snaplet's routes and cleanup actions, reading on-disk config files, and initializing and interacting with other snaplets. `Initializer` still uses a LensT implementation because it does not fit the more specialized case for which Lensed is optimized. But it is similar enough that we can still refer to snaplets using the same lenses that we use in Handlers. These similarities are abstracted in the MonadSnaplet type class. During initialization, sometimes you want to modify the result of another snaplet's initialization. For instance, maybe you want to add templates or bind splices for a sitewide Heist snaplet. Or perhaps you want to add controls to the admin panel snaplet. This involves modifying the state of other snaplets. It would be nice to use the same lenses and scoped modification via top-level state that we use in `Handler`. But in the initializer we don't yet have a fully constructed top-level state object to modify. So instead of actually modifying the state directly, we construct modifier functions to be applied at the end of initialization. Since these functions form a monoid, we can build them up using WriterT as LensT's underlying monad. The `Initializer` monad is used for both initialization and application reloading. When an application is reloaded from the browser, status and error messages should go to the browser instead of the console. The printInfo function sends messages to the appropriate place and should be used to communicate all initializer status and errors. ## Heist The Heist snaplet is a fairly complex snaplet that illustrates a number of concepts that you may encounter while writing your own snaplets. The biggest issue arises because Heist's TemplateState is parameterized by the handler monad. This means that if you want to do something like a with transformation with a lens `Lens b v` you will naturally want to apply the same transformation to the Handler parameter of the TemplateState. Unfortunately, due to Heist's design, this is computationally intensive, must be performed at runtime, and requires that you have a bijection between b and v. To avoid this issue, we only use the base application state, `TemplateState (Handler b b)`. The basic functions for manipulating templates are not affected by this decision. But the splice functions are more problematic since they are the ones that actually use TemplateState's monad parameter. You will also notice that the Heist snaplet includes a HasHeist type class. Normally to use snaplets, you must "call" them using with or withTop, passing the lens to the desired snaplet. This is useful because it allows you to have multiple instances of the same snaplet. However, there may be times when you know you will only ever need a single instance of a particular snaplet and you'd like to avoid the need to manually change the context every time. This is where type classes are useful. The HasHeist type class essentially defines some global compile-time state associating a particular lens to be used for calls to Heist within a particular type. To use Heist, just define a HasHeist instance for your application or snaplet type and all the Heist API functions will work without needing with. Your HasHeist instance will look something like this: instance HasHeist App where heistLens = subSnaplet heist The call to subSnaplet is required because HasHeist needs a `Lens (Snaplet v) (Snaplet (Heist b))` instead of the lens `Lens v (Snaplet (Heist b))` that you willll get from mkLabels. snap-1.1.2.0/extra/0000755000000000000000000000000000000000000012064 5ustar0000000000000000snap-1.1.2.0/extra/haddock.css0000755000000000000000000002023000000000000014173 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-1.1.2.0/extra/hscolour.css0000755000000000000000000000073700000000000014446 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-1.1.2.0/extra/logo.gif0000755000000000000000000000113700000000000013520 0ustar0000000000000000GIF89a` J"K#M%N(P1W1X3Z6\?d4e=i9i:j/dev/null 2>&1 cat <) or the documentation (). . Note: since version 1.0, the \"snap\" executable program for generating starter projects is provided by the @snap-templates@ package. 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.0.4 homepage: http://snapframework.com/ bug-reports: https://github.com/snapframework/snap/issues category: Web, Snap Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.1, GHC == 8.4.1, GHC == 8.6.1 extra-source-files: .ghci CONTRIBUTORS, LICENSE, README.md, README.SNAP.md, design.md, extra/hscolour.css, extra/haddock.css, extra/logo.gif, haddock.sh, runTestsAndCoverage.sh, test/bad.tpl, test/db.cfg, test/devel.cfg, test/good.tpl, test/snaplets/baz/devel.cfg test/snaplets/baz/templates/bazconfig.tpl test/snaplets/baz/templates/bazpage.tpl test/snaplets/embedded/extra-templates/extra.tpl, test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl, test/snaplets/foosnaplet/devel.cfg, test/snaplets/foosnaplet/templates/foopage.tpl, test/snaplets/heist/templates/_foopage.tpl, test/snaplets/heist/templates/extraTemplates/barpage.tpl, test/snaplets/heist/templates/foopage.tpl, test/snaplets/heist/templates/index.tpl, test/snaplets/heist/templates/page.tpl, test/snaplets/heist/templates/session.tpl, test/snaplets/heist/templates/splicepage.tpl, test/snaplets/heist/templates/userpage.tpl 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: Paths_snap Snap.Snaplet.Auth.AuthManager Snap.Snaplet.Auth.Types Snap.Snaplet.Auth.Handlers 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: aeson >= 0.6 && < 1.5, attoparsec >= 0.10 && < 0.14, base >= 4 && < 4.13, bytestring >= 0.9.1 && < 0.11, cereal >= 0.3 && < 0.6, clientsession >= 0.8 && < 0.10, configurator >= 0.1 && < 0.4, containers >= 0.2 && < 0.7, directory >= 1.1 && < 1.4, directory-tree >= 0.10 && < 0.13, dlist >= 0.5 && < 0.9, fail >= 4.9 && < 4.10, filepath >= 1.3 && < 1.5, -- hashable is broken from 1.2.0.0 through 1.2.0.5 -- snap does work with hashable 1.1.*, but some have complained that -- the version disjunction causes problems with dependency resolution. hashable >= 1.2.0.6 && < 1.3, heist >= 1.1 && < 1.2, lens >= 3.7.6 && < 4.18, lifted-base >= 0.2 && < 0.3, map-syntax >= 0.2 && < 0.4, monad-control >= 0.3 && < 1.1, mtl >= 2.0 && < 2.3, mwc-random >= 0.8 && < 0.15, pwstore-fast >= 2.2 && < 2.5, snap-core >= 1.0 && < 1.1, snap-server >= 1.0 && < 1.2, stm >= 2.2 && < 2.6, text >= 0.11 && < 1.3, time >= 1.1 && < 1.10, transformers >= 0.2 && < 0.6, transformers-base >= 0.4 && < 0.5, unordered-containers >= 0.1.4 && < 0.3, xmlhtml >= 0.1 && < 0.3 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16 && < 0.19 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 -fno-warn-orphans -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans Test-suite testsuite hs-source-dirs: src test/suite type: exitcode-stdio-1.0 main-is: TestSuite.hs other-modules: Blackbox.Tests Paths_snap SafeCWD Snap, Snap.Snaplet Snap.Snaplet.Auth Snap.Snaplet.Auth.AuthManager Snap.Snaplet.Auth.Backends.JsonFile Snap.Snaplet.Auth.Handlers Snap.Snaplet.Auth.Handlers.Tests Snap.Snaplet.Auth.SpliceHelpers Snap.Snaplet.Auth.SpliceTests Snap.Snaplet.Auth.Tests Snap.Snaplet.Auth.Types Snap.Snaplet.Auth.Types.Tests Snap.Snaplet.Test.Common.App Snap.Snaplet.Test.Common.BarSnaplet Snap.Snaplet.Test.Common.EmbeddedSnaplet Snap.Snaplet.Test.Common.FooSnaplet Snap.Snaplet.Test.Common.Handlers Snap.Snaplet.Test.Common.Types Snap.Snaplet.Config Snap.Snaplet.Config.Tests Snap.Snaplet.Heist Snap.Snaplet.Heist.Compiled Snap.Snaplet.Heist.Generic Snap.Snaplet.Heist.Internal Snap.Snaplet.Heist.Interpreted Snap.Snaplet.Heist.Tests Snap.Snaplet.HeistNoClass Snap.Snaplet.Internal.Initializer Snap.Snaplet.Internal.LensT Snap.Snaplet.Internal.LensT.Tests Snap.Snaplet.Internal.Lensed Snap.Snaplet.Internal.Lensed.Tests Snap.Snaplet.Internal.RST Snap.Snaplet.Internal.RST.Tests Snap.Snaplet.Internal.Tests Snap.Snaplet.Internal.Types Snap.Snaplet.Session Snap.Snaplet.Session.Backends.CookieSession Snap.Snaplet.Session.Common Snap.Snaplet.Session.SecureCookie Snap.Snaplet.Session.SessionManager Snap.Snaplet.Test Snap.Snaplet.Test.Tests Snap.TestCommon build-depends: aeson, async >= 2.0.1.5 && < 2.3, attoparsec, base, bytestring, cereal, clientsession, configurator, containers, deepseq, directory, directory-tree, dlist, fail, filepath, hashable, heist, http-streams >= 0.7.1.1 && < 0.9, HUnit >= 1.2.5.2 && < 1.7, lens, lifted-base, map-syntax, monad-control, mtl, mwc-random, pwstore-fast, QuickCheck >= 2.4.2 && < 2.13, smallcheck >= 1.1.1 && < 1.2, snap-core, snap-server, snap, stm, syb, test-framework >= 0.8.0.3 && < 0.9, test-framework-hunit >= 0.3.0.1 && < 0.4, test-framework-quickcheck2 >= 0.3.0.3 && < 0.4, test-framework-smallcheck >= 0.2 && < 0.3, text, time, transformers, transformers-base, unordered-containers, xmlhtml if !impl(ghc >= 8.0) build-depends: semigroups extensions: BangPatterns, CPP, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, NoMonomorphismRestriction, OverloadedStrings, PackageImports, Rank2Types, RecordWildCards, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeOperators, TypeSynonymInstances source-repository head type: git location: https://github.com/snapframework/snap.git snap-1.1.2.0/src/0000755000000000000000000000000000000000000011530 5ustar0000000000000000snap-1.1.2.0/src/Snap.hs0000644000000000000000000000060200000000000012763 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-1.1.2.0/src/Snap/0000755000000000000000000000000000000000000012431 5ustar0000000000000000snap-1.1.2.0/src/Snap/Snaplet.hs0000644000000000000000000002553600000000000014406 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 , serveSnapletNoArgParsing , 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-1.1.2.0/src/Snap/Snaplet/0000755000000000000000000000000000000000000014037 5ustar0000000000000000snap-1.1.2.0/src/Snap/Snaplet/Auth.hs0000644000000000000000000000330200000000000015272 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-1.1.2.0/src/Snap/Snaplet/Auth/0000755000000000000000000000000000000000000014740 5ustar0000000000000000snap-1.1.2.0/src/Snap/Snaplet/Auth/AuthManager.hs0000644000000000000000000000744500000000000017502 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) lookupByEmail :: 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 , rememberCookieDomain :: Maybe ByteString -- ^ Domain for which remember cookie will be created. , 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 lookupByEmail AuthManager{..} u = lookupByEmail backend u lookupByRememberToken AuthManager{..} u = lookupByRememberToken backend u destroy AuthManager{..} u = destroy backend u snap-1.1.2.0/src/Snap/Snaplet/Auth/Backends/0000755000000000000000000000000000000000000016452 5ustar0000000000000000snap-1.1.2.0/src/Snap/Snaplet/Auth/Backends/JsonFile.hs0000644000000000000000000003133300000000000020522 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} 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, listToMaybe) import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text as T import Data.Time import Web.ClientSession import System.Directory #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif 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 , rememberCookieDomain = Nothing , 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 #if !MIN_VERSION_aeson(1,0,0) -- In aeson >= 1 these instances are not needed because we have -- derived ToJSONKey/FromJSONKey instances for UserId. instance ToJSON UserIdCache where toJSON m = toJSON $ HM.toList m instance FromJSON UserIdCache where parseJSON = fmap HM.fromList . parseJSON #endif ------------------------------------------------------------------------------ type LoginUserCache = Map Text UserId ------------------------------------------------------------------------------ type EmailUserCache = 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 , emailCache :: EmailUserCache -- ^ fast lookup for email field , tokenCache :: RemTokenUserCache -- ^ fast lookup for remember tokens , uidCounter :: Int -- ^ user id counter } ------------------------------------------------------------------------------ defUserCache :: UserCache defUserCache = UserCache { uidCache = HM.empty , loginCache = HM.empty , emailCache = 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 , emailCache = maybe id (\em -> HM.insert em uid') (userEmail u) $ emailCache 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 oldEmail = userEmail x let oldToken = userRememberToken x let uid = fromJust $ userId u let newLogin = userLogin u let newEmail = userEmail 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 ec = if oldEmail /= newEmail then (case (oldEmail, newEmail) of (Nothing, Nothing) -> id (Just e, Nothing) -> HM.delete e (Nothing, Just e ) -> HM.insert e uid (Just e, Just e') -> HM.insert e' uid . HM.delete e ) (emailCache cache) else emailCache 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 , emailCache = ec , 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) lookupByEmail mgr email = withCache mgr f where f cache = getEmail >>= getUser cache where getEmail = case HM.lookup email (emailCache cache) of Just u -> return u Nothing -> (join . fmap userId . listToMaybe . HM.elems $ HM.filter ((== Just email) . userEmail) (uidCache 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 , "emailCache" .= emailCache uc , "tokenCache" .= tokenCache uc , "uidCounter" .= uidCounter uc ] ------------------------------------------------------------------------------ instance FromJSON UserCache where parseJSON (Object v) = UserCache <$> v .: "uidCache" <*> v .: "loginCache" <*> (v .: "emailCache" <|> pure mempty) -- Old versions of users.json do -- not carry this field <*> v .: "tokenCache" <*> v .: "uidCounter" parseJSON _ = error "Unexpected JSON input" snap-1.1.2.0/src/Snap/Snaplet/Auth/Handlers.hs0000644000000000000000000004751200000000000017045 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.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.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 cd <- gets rememberCookieDomain rp <- gets rememberPeriod withBackend $ loginByUsername' sk cn cd rp where -------------------------------------------------------------------------- loginByUsername' :: (IAuthBackend t) => Key -> ByteString -> Maybe ByteString -> Maybe Int -> t -> Handler b (AuthManager b) (Either AuthFailure AuthUser) loginByUsername' sk cn cd 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 cd 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 res <- runMaybeT $ do token <- MaybeT $ getRememberToken key cookieName_ period MaybeT $ liftIO $ lookupByRememberToken impl $ decodeUtf8 token case res of Nothing -> return $ Left $ AuthError "loginByRememberToken: no remember token" Just user -> do forceLogin user return $ Right user ------------------------------------------------------------------------------ -- | Logout the active user -- logout :: Handler b (AuthManager b) () logout = do s <- gets session withTop s $ withSession s removeSessionUserId rc <- gets rememberCookieName rd <- gets rememberCookieDomain expireSecureCookie rc rd 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 -> either (const Nothing) Just <$> 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 <- rqClientAddr <$> 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 ByteString -> Maybe Int -> t -> m () setRememberToken sk rc rd rp token = setSecureCookie rc rd sk rp token ------------------------------------------------------------------------------ -- | 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' = maybe (Left UsernameMissing) Right l let p' = maybe (Left PasswordMissing) Right 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 = loginUser' unf pwdf remf >>= either loginFail (const loginSucc) ------------------------------------------------------------------------------ loginUser' :: ByteString -> ByteString -> Maybe ByteString -> Handler b (AuthManager b) (Either AuthFailure AuthUser) loginUser' unf pwdf remf = do mbUsername <- getParam unf mbPassword <- getParam pwdf remember <- liftM (fromMaybe False) (runMaybeT $ do field <- MaybeT $ return remf value <- MaybeT $ getParam field return $ value == "1" || value == "on") case mbUsername of Nothing -> return $ Left UsernameMissing Just u -> case mbPassword of Nothing -> return $ Left PasswordMissing Just p -> loginByUsername (decodeUtf8 u) (ClearText p) 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-1.1.2.0/src/Snap/Snaplet/Auth/SpliceHelpers.hs0000644000000000000000000001677500000000000020056 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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.Map.Syntax ((##), mapV) import Data.Maybe 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 #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | 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-1.1.2.0/src/Snap/Snaplet/Auth/Types.hs0000644000000000000000000003135700000000000016411 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} module Snap.Snaplet.Auth.Types where ------------------------------------------------------------------------------ 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 (decodeUtf8, encodeUtf8) import Data.Typeable import Snap.Snaplet #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif ------------------------------------------------------------------------------ -- | 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 ) #if MIN_VERSION_aeson(1,0,0) deriving instance FromJSONKey UserId deriving instance ToJSONKey UserId #endif ------------------------------------------------------------------------------ -- | 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-1.1.2.0/src/Snap/Snaplet/Config.hs0000644000000000000000000000675300000000000015613 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} module Snap.Snaplet.Config where ------------------------------------------------------------------------------ import Data.Function (on) import Data.Maybe (fromMaybe) import Data.Monoid (Last(..), getLast) #if MIN_VERSION_base(4,10,0) import Data.Typeable (Typeable) #elif MIN_VERSION_base(4,7,0) import Data.Typeable.Internal (Typeable) #else import Data.Typeable (Typeable, TyCon, mkTyCon, mkTyConApp, typeOf) #endif #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid, mappend, mempty) #endif #if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup(..)) #endif import System.Console.GetOpt (OptDescr(Option), ArgDescr(ReqArg)) ------------------------------------------------------------------------------ import Snap.Core import Snap.Http.Server.Config (Config, fmapOpt, setOther, getOther, optDescrs ,extendedCommandLineConfig) ------------------------------------------------------------------------------ -- | 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 Semigroup AppConfig where a <> b = AppConfig { appEnvironment = ov appEnvironment a b } where ov f x y = getLast $! ((<>) `on` (Last . f)) x y ------------------------------------------------------------------------------ instance Monoid AppConfig where mempty = AppConfig Nothing #if !MIN_VERSION_base(4,11,0) mappend = (<>) #endif ------------------------------------------------------------------------------ -- | 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-1.1.2.0/src/Snap/Snaplet/Heist.hs0000644000000000000000000003151700000000000015456 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-1.1.2.0/src/Snap/Snaplet/Heist/0000755000000000000000000000000000000000000015113 5ustar0000000000000000snap-1.1.2.0/src/Snap/Snaplet/Heist/Compiled.hs0000644000000000000000000000637300000000000017214 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-1.1.2.0/src/Snap/Snaplet/Heist/Generic.hs0000644000000000000000000000137700000000000017033 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-1.1.2.0/src/Snap/Snaplet/Heist/Internal.hs0000644000000000000000000001147100000000000017227 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Snap.Snaplet.Heist.Internal where import Prelude import Control.Lens import Control.Monad.State import qualified Data.ByteString as B import Data.Char 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 $ (loadTemplates tDir) >>= either (error . concat) return printInfo $ T.pack $ unwords [ "...loaded" , (show $ Map.size templates) , "templates from" , tDir ] let config = initialConfig & hcTemplateLocations %~ (<> [loadTemplates tDir]) & hcCompiledTemplateFilter %~ (\f x -> f x && nsFilter x) 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 where nsFilter = (/=) (fromIntegral $ ord '_') . B.head . head ------------------------------------------------------------------------------ -- | Hook that converts the Heist type from Configuring to Running at the end -- of initialization. finalLoadHook :: Heist b -> IO (Either Text (Heist b)) finalLoadHook (Configuring ref) = do (hc,dm) <- readIORef ref res <- liftM toTextErrors $ initHeistWithCacheTag hc return $ case res of Left e -> Left e Right (hs,cts) -> Right $ Running hc hs cts dm where toTextErrors = mapBoth (T.pack . intercalate "\n") id finalLoadHook (Running _ _ _ _) = return $ Left "finalLoadHook called while running" mapBoth :: (a -> c) -> (b -> d) -> Either a b -> Either c d mapBoth f _ (Left x) = Left (f x) mapBoth _ f (Right x) = Right (f x) ------------------------------------------------------------------------------ -- | 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 $ initHeist $ _masterConfig h either (writeText . T.pack . unlines) (\hs -> do writeText "Heist reloaded." modifyMaster $ set heistState hs h) ehs snap-1.1.2.0/src/Snap/Snaplet/Heist/Interpreted.hs0000644000000000000000000000145700000000000017743 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-1.1.2.0/src/Snap/Snaplet/HeistNoClass.hs0000644000000000000000000004142200000000000016735 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 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 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 #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif 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 $ (loadTemplates templateDir) >>= either (error . concat) return printInfo $ T.pack $ unwords [ "...adding" , (show $ Map.size ts) , "templates from" , templateDir , "with route prefix" , fullPrefix ++ "/" ] let locations = [fmap 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 . Right . 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-1.1.2.0/src/Snap/Snaplet/Internal/0000755000000000000000000000000000000000000015613 5ustar0000000000000000snap-1.1.2.0/src/Snap/Snaplet/Internal/Initializer.hs0000644000000000000000000007101000000000000020431 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 , serveSnapletNoArgParsing , loadAppConfig , printInfo , getRoutes , getEnvironment , modifyMaster ) where ------------------------------------------------------------------------------ import Control.Applicative ((<$>)) import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, putMVar, readMVar) import Control.Exception.Lifted (SomeException, catch, try) import Control.Lens (ALens', cloneLens, over, set, storing, (^#)) import Control.Monad (Monad (..), join, liftM, unless, when, (=<<)) import Control.Monad.Reader (ask) import Control.Monad.State (get, modify) import Control.Monad.Trans (lift, liftIO) import Control.Monad.Trans.Writer hiding (pass) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Configurator (Worth (..), addToConfig, empty, loadGroups, subconfig) import qualified Data.Configurator.Types as C import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef) import Data.Maybe (Maybe (..), fromJust, fromMaybe, isNothing) import Data.Text (Text) import qualified Data.Text as T import Prelude (Bool (..), Either (..), Eq (..), String, concat, concatMap, const, either, error, filter, flip, fst, id, map, not, show, ($), ($!), (++), (.)) import Snap.Core (Snap, liftSnap, route) import Snap.Http.Server (Config, completeConfig, getCompression, getErrorHandler, getOther, getVerbose, httpServe) import Snap.Util.GZip (withCompression) import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, getCurrentDirectory) import System.Directory.Tree (DirTree (..), FileName, buildL, dirTree, readDirectoryWith) import System.FilePath.Posix (dropFileName, makeRelative, ()) import System.IO (FilePath, IO, hPutStrLn, stderr) ------------------------------------------------------------------------------ import Snap.Snaplet.Config (AppConfig, appEnvironment, commandLineAppConfig) import qualified Snap.Snaplet.Internal.Lensed as L import qualified Snap.Snaplet.Internal.LensT as LT 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'. Useful 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 -> IO (Either Text v)) -> (Snaplet v -> IO (Either Text (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 -> IO (Either Text v)) -> Initializer b v () addPostInitHook = addPostInitHook' . toSnapletHook addPostInitHook' :: (Snaplet v -> IO (Either Text (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 -> IO (Either Text (Snaplet b))) -> Initializer b v () addPostInitHookBase = Initializer . lift . tell . Hook ------------------------------------------------------------------------------ -- | Helper function for transforming hooks. upHook :: (Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v (Snaplet b -> IO (Either Text (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 (Either e a)) -> b -> m (Either e b) upHook' l h b = do v <- h (b ^# l) return $ case v of Left e -> Left e Right v' -> Right $ 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 almost 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 = do ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $ InitializerState True cleanupRef builtinHandlers id cfg logRef env resetter res' <- hook res return $ (,s) <$> res' 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 serveSnapletNoArgParsing config initializer ------------------------------------------------------------------------------ -- | Like 'serveSnaplet', but don't try to parse command-line arguments. serveSnapletNoArgParsing :: 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 () serveSnapletNoArgParsing config initializer = do let env = appEnvironment =<< getOther config (msgs, handler, doCleanup) <- runSnaplet env initializer (conf, site) <- combineConfig config handler createDirectoryIfMissing False "log" let serve = httpServe 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-1.1.2.0/src/Snap/Snaplet/Internal/LensT.hs0000644000000000000000000001072100000000000017175 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Snap.Snaplet.Internal.LensT where ------------------------------------------------------------------------------ import Control.Applicative (Alternative (..), Applicative (..)) import Control.Category ((.)) import Control.Lens (ALens', cloneLens, storing, (^#)) import Control.Monad (MonadPlus (..)) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Reader (MonadReader (..)) import Control.Monad.State.Class (MonadState (..)) import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), defaultLiftBaseWith, defaultLiftWith, defaultRestoreM, defaultRestoreT) import Prelude (Functor (..), Monad (..), const, ($), ($!)) import Snap.Core (MonadSnap (..)) import Snap.Snaplet.Internal.RST (RST (..), runRST, withRST) ------------------------------------------------------------------------------ newtype LensT b v s m a = LensT (RST (ALens' b v) s m a) deriving ( Monad , MonadTrans , Functor , Applicative , MonadIO , MonadPlus , Alternative , MonadReader (ALens' b v)) ------------------------------------------------------------------------------ instance Monad m => MonadState v (LensT b v b m) where get = lGet put = lPut instance MonadBase bs m => MonadBase bs (LensT b v s m) where liftBase = lift . liftBase instance MonadBaseControl bs m => MonadBaseControl bs (LensT b v s m) where type StM (LensT b v s m) a = ComposeSt (LensT b v s) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} instance MonadTransControl (LensT b v s) where type StT (LensT b v s) a = StT (RST (ALens' b v) s) a liftWith = defaultLiftWith LensT (\(LensT rst) -> rst) restoreT = defaultRestoreT LensT {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance MonadSnap m => MonadSnap (LensT b v s m) where liftSnap m = LensT $ liftSnap m ------------------------------------------------------------------------------ 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-1.1.2.0/src/Snap/Snaplet/Internal/Lensed.hs0000644000000000000000000001563100000000000017367 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Snap.Snaplet.Internal.Lensed where ------------------------------------------------------------------------------ import Control.Applicative (Alternative (..), Applicative (..), (<$>)) import Control.Category ((.)) import Control.Lens (ALens', cloneLens, storing, (^#)) import Control.Monad (MonadPlus (..), liftM) import Control.Monad.Base (MonadBase (..)) import qualified Control.Monad.Fail as Fail import Control.Monad.Reader (MonadReader (..)) import Control.Monad.State.Class (MonadState (..)) import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), defaultLiftBaseWith, defaultRestoreM) import Control.Monad.Trans.State (StateT(..)) import Prelude (Functor (..), Monad (..), ($)) import Snap.Core (MonadSnap (..)) ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ 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 Fail.MonadFail m => Fail.MonadFail (Lensed b v m) where fail s = Lensed $ \_ _ _ -> Fail.fail 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 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 ------------------------------------------------------------------------------ instance MonadBase base m => MonadBase base (Lensed b v m) where liftBase = lift . liftBase ------------------------------------------------------------------------------ instance MonadBaseControl base m => MonadBaseControl base (Lensed b v m) where type StM (Lensed b v m) a = ComposeSt (Lensed b v) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} ------------------------------------------------------------------------------ instance MonadTransControl (Lensed b v) where type StT (Lensed b v) a = (a, v, b) liftWith f = Lensed $ \l v b -> do res <- f $ \(Lensed g) -> g l v b return (res, v, b) restoreT k = Lensed $ \_ _ _ -> k {-# INLINE liftWith #-} {-# INLINE restoreT #-} ------------------------------------------------------------------------------ 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-1.1.2.0/src/Snap/Snaplet/Internal/RST.hs0000644000000000000000000000764500000000000016633 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Snap.Snaplet.Internal.RST where import Control.Applicative (Alternative (..), Applicative (..)) import Control.Category ((.)) import Control.Monad (MonadPlus (..), ap) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Reader (MonadReader (..)) import Control.Monad.State.Class (MonadState (..)) import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), defaultLiftBaseWith, defaultRestoreM) import Prelude (Functor (..), Monad (..), seq, ($)) import Snap.Core (MonadSnap (..)) ------------------------------------------------------------------------------ -- 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 (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 (MonadIO m) => MonadIO (RST r s m) where liftIO = lift . liftIO instance MonadTrans (RST r s) where lift m = RST $ \_ s -> do a <- m return $ s `seq` (a, s) instance MonadBase b m => MonadBase b (RST r s m) where liftBase = lift . liftBase instance MonadBaseControl b m => MonadBaseControl b (RST r s m) where type StM (RST r s m) a = ComposeSt (RST r s) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} instance MonadTransControl (RST r s) where type StT (RST r s) a = (a, s) liftWith f = RST $ \r s -> do res <- f $ \(RST g) -> g r s return (res, s) restoreT k = RST $ \_ _ -> k {-# INLINE liftWith #-} {-# INLINE restoreT #-} snap-1.1.2.0/src/Snap/Snaplet/Internal/Types.hs0000644000000000000000000005047300000000000017264 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #ifndef MIN_VERSION_comonad #define MIN_VERSION_comonad(x,y,z) 1 #endif module Snap.Snaplet.Internal.Types where ------------------------------------------------------------------------------ import Control.Applicative (Alternative) import Control.Lens (ALens', makeLenses, set) import Control.Monad (liftM) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Fail (MonadFail) import Control.Monad.Reader (MonadIO (..), MonadPlus, MonadReader (ask, local)) import Control.Monad.State.Class (MonadState (get, put), gets) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Writer (WriterT) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B (dropWhile, intercalate, null, reverse) import Data.Configurator.Types (Config) import Data.IORef (IORef) import Data.Text (Text) import Snap.Core (MonadSnap, Request (rqClientAddr), Snap, bracketSnap, getRequest, pass, writeText) import qualified Snap.Snaplet.Internal.Lensed as L (Lensed (..), runLensed, with, withTop) import qualified Snap.Snaplet.Internal.LensT as LT (LensT, getBase, with, withTop) #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative) import Data.Monoid (Monoid (mappend, mempty)) #endif #if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup(..)) #endif ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | 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 -} -- NOTE: We cannot use one of the smaller lens packages because none of them -- include ALens'. We have to use ALens' because we use lenses inside f's... -- f (Lens a b). That requires ImpredicativeTypes which doesn't work. We -- also can't inline the type aliases because ALens' uses Pretext which is a -- newtype and can't be supplied outside lens in a compatible way. ------------------------------------------------------------------------------ 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 { _unHandler :: L.Lensed (Snaplet b) (Snaplet v) Snap a } deriving ( Monad , Functor , Applicative , MonadFail , MonadIO , MonadPlus , Alternative , MonadSnap) ------------------------------------------------------------------------------ instance MonadBase IO (Handler b v) where liftBase = liftIO ------------------------------------------------------------------------------ newtype StMHandler b v a = StMHandler { unStMHandler :: StM (L.Lensed (Snaplet b) (Snaplet v) Snap) a } instance MonadBaseControl IO (Handler b v) where type StM (Handler b v) a = StMHandler b v a liftBaseWith f = Handler $ liftBaseWith $ \g' -> f $ \m -> liftM StMHandler $ g' $ _unHandler m restoreM = Handler . restoreM . unStMHandler ------------------------------------------------------------------------------ -- | 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) ------------------------------------------------------------------------------ -- | Lets you access the current snaplet's state through the 'MonadState' -- interface. instance MonadState v (Handler b v) where get = getsSnapletState _snapletValue put v = modifySnapletState (set snapletValue v) ------------------------------------------------------------------------------ -- | Lets you access the current snaplet's state through the 'MonadReader' -- interface. 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)) ------------------------------------------------------------------------------ -- | Check whether the request comes from localhost. isLocalhost :: MonadSnap m => m Bool isLocalhost = do rip <- liftM rqClientAddr getRequest return $ elem rip [ "127.0.0.1" , "localhost" , "::1" ] ------------------------------------------------------------------------------ -- | Pass if the request is not coming from localhost. failIfNotLocal :: MonadSnap m => m b -> m b failIfNotLocal m = do isLocal <- isLocalhost if isLocal then m else pass ------------------------------------------------------------------------------ -- | 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 -> IO (Either Text (Snaplet a))) instance Semigroup (Hook a) where Hook a <> Hook b = Hook $ \s -> do ea <- a s case ea of Left e -> return $ Left e Right ares -> do eb <- b ares case eb of Left e -> return $ Left e Right bres -> return $ Right bres ------------------------------------------------------------------------------ instance Monoid (Hook a) where mempty = Hook (return . Right) #if !MIN_VERSION_base(4,11,0) mappend = (<>) #endif ------------------------------------------------------------------------------ -- | 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-1.1.2.0/src/Snap/Snaplet/Session.hs0000644000000000000000000000752200000000000016024 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-1.1.2.0/src/Snap/Snaplet/Session/Backends/0000755000000000000000000000000000000000000017174 5ustar0000000000000000snap-1.1.2.0/src/Snap/Snaplet/Session/Backends/CookieSession.hs0000644000000000000000000002010000000000000022276 0ustar0000000000000000------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.Session.Backends.CookieSession ( initCookieSessionManager ) where ------------------------------------------------------------------------------ import Control.Monad.Reader import Data.ByteString (ByteString) import Data.Typeable 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 Snap.Core (Snap) import Web.ClientSession #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif ------------------------------------------------------------------------------ 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 , cookieDomain :: Maybe ByteString -- ^ Cookie domain for session system. You may want to set it to -- dot prefixed domain name like ".example.com", so the cookie is -- available to sub domains. , 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 ByteString -- ^ Session cookie domain -> Maybe Int -- ^ Session time-out (replay attack protection) -> SnapletInit b SessionManager initCookieSessionManager fp cn dom 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 dom 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) (cookieDomain mgr) (siteKey mgr) (timeOut mgr) x snap-1.1.2.0/src/Snap/Snaplet/Session/0000755000000000000000000000000000000000000015462 5ustar0000000000000000snap-1.1.2.0/src/Snap/Snaplet/Session/Common.hs0000644000000000000000000000353700000000000017256 0ustar0000000000000000{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ -- | This module contains functionality common among multiple back-ends. -- module Snap.Snaplet.Session.Common ( RNG , mkRNG , withRNG , randomToken , mkCSRFToken ) where ------------------------------------------------------------------------------ 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 #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif ------------------------------------------------------------------------------ -- | 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-1.1.2.0/src/Snap/Snaplet/Session/SecureCookie.hs0000644000000000000000000001147700000000000020410 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 ( SecureCookie , getSecureCookie , setSecureCookie , expireSecureCookie -- ** Helper functions , encodeSecureCookie , decodeSecureCookie , checkTimeout ) where ------------------------------------------------------------------------------ import Control.Monad import Control.Monad.Trans import Data.ByteString (ByteString) import Data.Serialize import Data.Time import Data.Time.Clock.POSIX import Snap.Core import Web.ClientSession #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif ------------------------------------------------------------------------------ -- | Arbitrary payload with timestamp. type SecureCookie t = (UTCTime, t) ------------------------------------------------------------------------------ -- | Get the cookie payload. 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 >>= decodeSecureCookie key case val of Nothing -> return Nothing Just (ts, t) -> do to <- checkTimeout timeout ts return $ case to of True -> Nothing False -> Just t ------------------------------------------------------------------------------ -- | Decode secure cookie payload wih key. decodeSecureCookie :: Serialize a => Key -- ^ Encryption key -> ByteString -- ^ Encrypted payload -> Maybe (SecureCookie a) decodeSecureCookie key value = do cv <- decrypt key value (i, val) <- either (const Nothing) Just $ decode cv return $ (posixSecondsToUTCTime (fromInteger i), val) ------------------------------------------------------------------------------ -- | Inject the payload. setSecureCookie :: (MonadSnap m, Serialize t) => ByteString -- ^ Cookie name -> Maybe ByteString -- ^ Cookie domain -> Key -- ^ Encryption key -> Maybe Int -- ^ Max age in seconds -> t -- ^ Serializable payload -> m () setSecureCookie name domain key to val = do t <- liftIO getCurrentTime val' <- encodeSecureCookie key (t, val) let expire = to >>= Just . flip addUTCTime t . fromIntegral let nc = Cookie name val' expire domain (Just "/") False True modifyResponse $ addResponseCookie nc ------------------------------------------------------------------------------ -- | Encode SecureCookie with key into injectable payload encodeSecureCookie :: (MonadIO m, Serialize t) => Key -- ^ Encryption key -> SecureCookie t -- ^ Payload -> m ByteString encodeSecureCookie key (t, val) = liftIO $ encryptIO key . encode $ (seconds, val) where seconds = round (utcTimeToPOSIXSeconds t) :: Integer ------------------------------------------------------------------------------ -- | Expire secure cookie expireSecureCookie :: MonadSnap m => ByteString -- ^ Cookie name -> Maybe ByteString -- ^ Cookie domain -> m () expireSecureCookie name domain = expireCookie cookie where cookie = Cookie name "" Nothing domain (Just "/") False False ------------------------------------------------------------------------------ -- | 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-1.1.2.0/src/Snap/Snaplet/Session/SessionManager.hs0000644000000000000000000000375500000000000020746 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-1.1.2.0/src/Snap/Snaplet/Test.hs0000644000000000000000000001472400000000000015322 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-1.1.2.0/test/0000755000000000000000000000000000000000000011720 5ustar0000000000000000snap-1.1.2.0/test/bad.tpl0000755000000000000000000000001600000000000013167 0ustar0000000000000000 snap-1.1.2.0/test/snaplets/baz/templates/bazpage.tpl0000755000000000000000000000003700000000000020460 0ustar0000000000000000baz template page snap-1.1.2.0/test/snaplets/embedded/extra-templates/0000755000000000000000000000000000000000000020421 5ustar0000000000000000snap-1.1.2.0/test/snaplets/embedded/extra-templates/extra.tpl0000755000000000000000000000003200000000000022263 0ustar0000000000000000This is an extra template snap-1.1.2.0/test/snaplets/embedded/snaplets/heist/templates/0000755000000000000000000000000000000000000022245 5ustar0000000000000000snap-1.1.2.0/test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl0000755000000000000000000000004100000000000025352 0ustar0000000000000000embedded snaplet page snap-1.1.2.0/test/snaplets/foosnaplet/0000755000000000000000000000000000000000000015723 5ustar0000000000000000snap-1.1.2.0/test/snaplets/foosnaplet/devel.cfg0000755000000000000000000000003600000000000017505 0ustar0000000000000000fooSnapletField = "fooValue" snap-1.1.2.0/test/snaplets/foosnaplet/templates/0000755000000000000000000000000000000000000017721 5ustar0000000000000000snap-1.1.2.0/test/snaplets/foosnaplet/templates/foopage.tpl0000755000000000000000000000002200000000000022057 0ustar0000000000000000foo template page snap-1.1.2.0/test/snaplets/heist/templates/0000755000000000000000000000000000000000000016663 5ustar0000000000000000snap-1.1.2.0/test/snaplets/heist/templates/_foopage.tpl0000755000000000000000000000014700000000000021170 0ustar0000000000000000

An underscore template.

snap-1.1.2.0/test/snaplets/heist/templates/extraTemplates/0000755000000000000000000000000000000000000021665 5ustar0000000000000000snap-1.1.2.0/test/snaplets/heist/templates/extraTemplates/barpage.tpl0000755000000000000000000000006300000000000024011 0ustar0000000000000000 Hi. Bar. snap-1.1.2.0/test/snaplets/heist/templates/foopage.tpl0000755000000000000000000000010400000000000021022 0ustar0000000000000000 Hi. snap-1.1.2.0/test/snaplets/heist/templates/index.tpl0000755000000000000000000000001300000000000020510 0ustar0000000000000000index page snap-1.1.2.0/test/snaplets/heist/templates/page.tpl0000755000000000000000000000013100000000000020316 0ustar0000000000000000 Example App snap-1.1.2.0/test/snaplets/heist/templates/session.tpl0000755000000000000000000000001300000000000021064 0ustar0000000000000000 snap-1.1.2.0/test/snaplets/heist/templates/splicepage.tpl0000755000000000000000000000003100000000000021515 0ustar0000000000000000splice page snap-1.1.2.0/test/snaplets/heist/templates/userpage.tpl0000755000000000000000000000162000000000000021221 0ustar0000000000000000

is logged in You are not logged in

loggedInUser:

UserID

UserLogin

UserEmail

UserActive

UserLoginCount

UserFailedCount

UserLoginAt

UserLastLoginAt

UserSuspendedAt

UserLoginIP

UserLastLoginIP

UserIfActive

userIfSuspended

snap-1.1.2.0/test/suite/Blackbox/0000755000000000000000000000000000000000000014576 5ustar0000000000000000snap-1.1.2.0/test/suite/Blackbox/Tests.hs0000644000000000000000000003250200000000000016236 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Blackbox.Tests ( tests , remove , removeDir ) where ------------------------------------------------------------------------------ import Control.Exception (catch, finally, 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" , requestExpectingErrorPrefix "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 --testName = id ------------------------------------------------------------------------------ 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]) ------------------------------------------------------------------------------ requestExpectingErrorPrefix :: String -> Int -> Text -> Test requestExpectingErrorPrefix url status desired = testCase (testName url) $ requestExpectingErrorPrefix' url status desired ------------------------------------------------------------------------------ requestExpectingErrorPrefix' :: String -> Int -> Text -> IO () requestExpectingErrorPrefix' 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 assertBool fullUrl $ desired `T.isPrefixOf` (T.decodeUtf8 $ L.fromChunks [res]) ------------------------------------------------------------------------------ fooConfigPathTest :: Test fooConfigPathTest = testCase (testName "foo/fooFilePath") $ do b <- liftM L.unpack $ grab "/foo/fooFilePath" assertRelativelyTheSame b "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 , "/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 , "/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 , "/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 , "\",Just \"app\"," -- TODO, right? , "\"Test application\",\"\") " , "([\"app\"],\"" , S.pack cwd , "/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 "snaplets/foosnaplet" ------------------------------------------------------------------------------ reloadTest :: Test reloadTest = testCase "internal/reload-test" $ do let goodTplOrig = "good.tpl" let badTplOrig = "bad.tpl" let goodTplNew = "snaplets" "heist" "templates" "good.tpl" let badTplNew = "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" flip finally (remove badTplNew) $ 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' , "/snaplets/heist" , "/templates/bad.tpl \"" , T.pack cwd' , "/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" ] ,T.concat [ "Error reloading site!\n\nInitializer " , "threw an exception...\n" , T.pack cwd' , "/snaplets/heist" , "/templates/bad.tpl \"" , T.pack cwd' , "/snaplets/heist/templates" , "/bad.tpl\" (line 2, column 1):\nunexpected " , "end of input\nexpecting \"=\", \"/\" or " , "\">\"\n" , "CallStack (from HasCallStack):\n error, called at src/Snap/Snaplet/Heist/Internal.hs:74:35 in main:Snap.Snaplet.Heist.Internal\n" , "\n...but before it died it generated " , "the following output:\nInitializing app @ /\n" , "Initializing heist @ /heist\n\n" ] ] assertBool "admin/reload" $ (T.decodeUtf8 b) `elem` response copyFile goodTplOrig goodTplNew testWithCwd' "admin/reload" $ \cwd' b -> do -- TODO/NOTE: Needs cleanup let cwd = S.pack cwd' let response = L.fromChunks [ "Initializing app @ /\nInitializing heist @ ", "/heist\n...loaded 9 templates from ", cwd, "/snaplets/heist/templates\nInitializing CookieSession ", "@ /session\nInitializing foosnaplet @ /foo\n...adding 1 ", "templates from ", cwd, "/snaplets/foosnaplet/templates with route prefix ", "foo/\nInitializing baz @ /\n...adding 2 templates from ", cwd, "/snaplets/baz/templates with route prefix /\nInitializing ", "embedded @ /\nInitializing heist @ /heist\n...loaded ", "1 templates from ", cwd, "/snaplets/embedded/snaplets/heist/templates\n...adding ", "1 templates from ", cwd, "/snaplets/embedded/extra-templates with route prefix ", "onemoredir/\n...adding 0 templates from ", cwd, "/templates with route prefix extraTemplates/\n", "Initializing JsonFileAuthManager @ ", "/auth\nSite successfully reloaded.\n" ] assertEqual "admin/reload" response b requestTest' "good" "Good template\n" snap-1.1.2.0/test/suite/0000755000000000000000000000000000000000000013051 5ustar0000000000000000snap-1.1.2.0/test/suite/SafeCWD.hs0000644000000000000000000000141500000000000014622 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-1.1.2.0/test/suite/Snap/Snaplet/Auth/Handlers/0000755000000000000000000000000000000000000020021 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs0000644000000000000000000006647500000000000021501 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.Auth.Handlers.Tests ( tests ) where ------------------------------------------------------------------------------ import Control.Applicative import Control.Monad.State as S import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import qualified Data.Map as Map import Data.Maybe (isJust, isNothing) import Data.Time.Clock (diffUTCTime, getCurrentTime) import Test.Framework (Test, mutuallyExclusive, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit hiding (Test, path) ------------------------------------------------------------------------------ import Snap.Core (writeText) import Snap.Snaplet (Handler, with) import Snap.Snaplet.Auth (AuthUser(..), AuthFailure(..), Password(..), Role(..)) import qualified Snap.Snaplet.Auth as A import Snap.Snaplet.Test.Common.App (App, appInit, appInit', auth) import qualified Snap.Test as ST import Snap.Snaplet.Test (evalHandler, runHandler, withTemporaryFile) ------------------------------------------------------------------------------ tests :: Test tests = testGroup "Snap.Snaplet.Auth.Handlers" [mutuallyExclusive $ testGroup "createUser tests" [ testCreateUserGood , testWithCfgFile , testCreateUserTimely , testCreateUserWithRole , testCreateEmptyUser , testCreateDupUser , testUsernameExists , testLoginByUsername , testLoginByUsernameEnc , testLoginByUsernameNoU , testLoginByUsernameInvPwd , testLoginByRememberTokenKO , testLoginByRememberTokenOK , testLogoutKO , testLogoutOK , testCurrentUserKO , testCurrentUserOK , testIsLoggedInKO , testIsLoggedInOK , testSaveUserKO , testSaveUserOK , testMarkAuthFail --, testMarkAuthFailLockedOut , testMarkAuthSuccess , testCheckPasswordAndLoginOK , testCheckPasswordAndLoginKO , testAuthenticatePasswordOK , testAuthenticatePasswordPwdMissing , testAuthenticatePasswordPwdWrong , testRegisterUserOK , testRegisterUserNoUser , testRegisterUserNoPwd , testRequireUserOK , testRequireUserKO ] ] ------------------------------------------------------------------------------ isJustFailure :: AuthFailure -> Maybe AuthFailure -> Bool isJustFailure failure (Just expected) = failure == expected isJustFailure _ _ = False ------------------------------------------------------------------------------ isLeftFailure :: AuthFailure -> Either AuthFailure AuthUser -> Bool isLeftFailure failure (Left expected) = failure == expected isLeftFailure _ _ = False ------------------------------------------------------------------------------ testCreateUserGood :: Test testCreateUserGood = testCase "createUser good params" assertGoodUser where assertGoodUser :: Assertion assertGoodUser = withTemporaryFile "users.json" $ do let hdl = with auth $ A.createUser "foo" "foo" res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isRight) res failMsg = "createUser failed: Couldn't create a new user." ------------------------------------------------------------------------------ testWithCfgFile :: Test testWithCfgFile = testCase "createUser with config file settings" assertCfg where assertCfg :: Assertion assertCfg = withTemporaryFile "users.json" $ do let hdl = with auth $ A.createUser "foo" "foo" res <- runHandler Nothing (ST.get "" Map.empty) hdl (appInit' False True) either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ testCreateUserTimely :: Test testCreateUserTimely = testCase "createUser good updatedAt" assertCreateTimely where assertCreateTimely :: Assertion assertCreateTimely = withTemporaryFile "users.json" $ do let hdl = with auth $ A.createUser "foo" "foo" tNow <- getCurrentTime let isTimely t' = maybe False (\t -> diffUTCTime tNow t < 1) t' res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit case res of Left e -> assertFailure . show $ e Right (Left e) -> assertFailure . show $ e Right (Right au) -> assertBool failMsg $ isTimely (userUpdatedAt au) && isTimely (userCreatedAt au) failMsg = "createUser: userUpdatedAt, userCreatetAt times not set" hush :: Either e a -> Maybe a hush (Left _) = Nothing hush (Right a) = Just a ------------------------------------------------------------------------------ testCreateUserWithRole :: Test testCreateUserWithRole = testCase "createUser with role" assertUserRole where assertUserRole :: Assertion assertUserRole = withTemporaryFile "users.json" $ do let hdl = with auth $ runMaybeT $ do u <- MaybeT $ hush <$> A.createUser "foo" "foo" _ <- MaybeT $ hush <$> A.saveUser (u {userRoles = [Role "admin",Role "user"]}) MaybeT $ hush <$> A.loginByUsername "foo" (ClearText "foo") False res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit case res of Left e -> assertFailure $ show e Right Nothing -> assertFailure "Failed saved user lookup" Right (Just usr) -> assertEqual "Roles don't match expectation" [Role "admin",Role "user"] (userRoles usr) ------------------------------------------------------------------------------ testCreateEmptyUser :: Test testCreateEmptyUser = testCase "createUser empty username" assertEmptyUser where assertEmptyUser :: Assertion assertEmptyUser = do let hdl = with auth $ A.createUser "" "foo" res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isLeftFailure UsernameMissing) res failMsg = "createUser: Was created an empty username despite they aren't allowed." ------------------------------------------------------------------------------ -- Is the tests execution order garanteed? When this runs, the user "foo" -- will be already present in the backend. testCreateDupUser :: Test testCreateDupUser = testCase "createUser duplicate user" assertDupUser where assertDupUser :: Assertion assertDupUser = do let hdl = with auth $ A.createUser "foo" "foo" res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isLeftFailure DuplicateLogin) res failMsg = "createUser: Expected to find a duplicate user, but I haven't." ------------------------------------------------------------------------------ -- A non desirable thing is to be couple by the temporal execution of -- tests. The problem has been resolved using fixtures, so something like -- that would be beneficial for next releases. testUsernameExists :: Test testUsernameExists = testCase "username exists" assertUserExists where assertUserExists :: Assertion assertUserExists = do let hdl = with auth $ A.usernameExists "foo" res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg) res failMsg = "usernameExists: Expected to return True, but it didn't." ------------------------------------------------------------------------------ testLoginByUsername :: Test testLoginByUsername = testCase "successful loginByUsername" assertion where assertion :: Assertion assertion = do let pwd = ClearText "foo" res <- evalHandler Nothing (ST.get "" Map.empty) (loginByUnameHdlr pwd) appInit either (assertFailure . show) (assertBool failMsg . isRight) res failMsg = "loginByUsername: Failed with ClearText pwd." ------------------------------------------------------------------------------ -- Reused below. loginByUnameHdlr :: Password -> Handler App App (Either AuthFailure AuthUser) loginByUnameHdlr pwd = with auth $ A.loginByUsername "foo" pwd False ------------------------------------------------------------------------------ testLoginByUsernameEnc :: Test testLoginByUsernameEnc = testCase "loginByUsername encrypted pwd" assertion where assertion :: Assertion assertion = do let pwd = Encrypted "foo" res <- evalHandler Nothing (ST.get "" Map.empty) (loginByUnameHdlr pwd) appInit either (assertFailure . show) (assertBool failMsg . isLeftFailure EncryptedPassword) res failMsg = "loginByUsername: Expected to find an Encrypted password, but I haven't." ------------------------------------------------------------------------------ testLoginByUsernameNoU :: Test testLoginByUsernameNoU = testCase "loginByUsername invalid user" assertion where assertion :: Assertion assertion = do let pwd = ClearText "foo" let hdl = with auth $ A.loginByUsername "doesnotexist" pwd False res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isLeftFailure UserNotFound) res failMsg = "loginByUsername: Expected to fail for an invalid user, but I didn't." ------------------------------------------------------------------------------ testLoginByUsernameInvPwd :: Test testLoginByUsernameInvPwd = testCase "loginByUsername invalid user" assertion where assertion :: Assertion assertion = do let pwd = ClearText "invalid" let hdl = with auth $ A.loginByUsername "foo" pwd False res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isLeft) res failMsg = "loginByUsername: Expected to fail for an invalid pwd, but I didn't." ------------------------------------------------------------------------------ testLoginByRememberTokenKO :: Test testLoginByRememberTokenKO = testCase "loginByRememberToken no token" assertion where assertion :: Assertion assertion = do let hdl = with auth A.loginByRememberToken res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isLeft) res failMsg = "loginByRememberToken: Expected to fail for the " ++ "absence of a token, but I didn't." ------------------------------------------------------------------------------ testLoginByRememberTokenOK :: Test testLoginByRememberTokenOK = testCase "loginByRememberToken token" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit case res of (Left e) -> assertFailure $ show e (Right res') -> assertBool failMsg $ isRight res' hdl :: Handler App App (Either AuthFailure AuthUser) hdl = with auth $ do res <- A.loginByUsername "foo" (ClearText "foo") True either (\e -> return (Left e)) (\_ -> A.loginByRememberToken) res failMsg = "loginByRememberToken: Expected to succeed but I didn't." ------------------------------------------------------------------------------ testLogoutKO :: Test testLogoutKO = testCase "logout no user logged in." $ assertLogout hdl failMsg where hdl :: Handler App App (Maybe AuthUser) hdl = with auth $ do A.logout mgr <- S.get return (A.activeUser mgr) failMsg = "logout: Expected to get Nothing as the active user, " ++ " but I didn't." ------------------------------------------------------------------------------ assertLogout :: Handler App App (Maybe AuthUser) -> String -> Assertion assertLogout hdl failMsg = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isNothing) res ------------------------------------------------------------------------------ testLogoutOK :: Test testLogoutOK = testCase "logout user logged in." $ assertLogout hdl failMsg where hdl :: Handler App App (Maybe AuthUser) hdl = with auth $ do _ <- A.loginByUsername "foo" (ClearText "foo") True A.logout mgr <- get return (A.activeUser mgr) failMsg = "logout: Expected to get Nothing as the active user, " ++ " but I didn't." ------------------------------------------------------------------------------ testCurrentUserKO :: Test testCurrentUserKO = testCase "currentUser unsuccesful call" assertion where assertion :: Assertion assertion = do let hdl = with auth A.currentUser res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isNothing) res failMsg = "currentUser: Expected Nothing as the current user, " ++ " but I didn't." ------------------------------------------------------------------------------ testCurrentUserOK :: Test testCurrentUserOK = testCase "successful currentUser call" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isJust) res hdl :: Handler App App (Maybe AuthUser) hdl = with auth $ do res <- A.loginByUsername "foo" (ClearText "foo") True either (\_ -> return Nothing) (\_ -> A.currentUser) res failMsg = "currentUser: Expected to get the current user, " ++ " but I didn't." ------------------------------------------------------------------------------ testIsLoggedInKO :: Test testIsLoggedInKO = testCase "isLoggedIn, no user logged" assertion where assertion :: Assertion assertion = do let hdl = with auth A.isLoggedIn res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . not) res failMsg = "isLoggedIn: Expected False, but got True." ------------------------------------------------------------------------------ testIsLoggedInOK :: Test testIsLoggedInOK = testCase "isLoggedIn, user logged" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg) res hdl :: Handler App App Bool hdl = with auth $ do _ <- A.loginByUsername "foo" (ClearText "foo") True A.isLoggedIn failMsg = "isLoggedIn: Expected True, but got False." ------------------------------------------------------------------------------ -- It fails because destroy is not yet implemented for the Json backend. testDestroyUser :: Test testDestroyUser = testCase "destroyUser" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . not) res hdl :: Handler App App Bool hdl = with auth $ do newUser <- A.createUser "bar" "bar" either (\_ -> return True) (\u -> A.destroyUser u >> A.usernameExists "bar") newUser failMsg = "destroyUser: I've tried to destroy an existing user, " ++ "but user is still there." ------------------------------------------------------------------------------ testSaveUserKO :: Test testSaveUserKO = testCase "saveUser null username" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isLeft) res hdl :: Handler App App (Either AuthFailure AuthUser) hdl = with auth $ do user <- A.loginByUsername "foo" (ClearText "foo") True case user of (Left e) -> return $ Left e (Right u) -> A.saveUser (u { userLogin = "" }) failMsg = "saveUser: I expected to fail since I'm saving an " ++ "empty username, but I didn't." ------------------------------------------------------------------------------ -- Trying to update a Cleartext text pwd result in an error. Feature or -- bug? (error: Json can't serialize ClearText pwd) testSaveUserOK :: Test testSaveUserOK = testCase "saveUser good update params" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isRight) res hdl :: Handler App App (Either AuthFailure AuthUser) hdl = with auth $ do user <- A.loginByUsername "foo" (ClearText "foo") True case user of (Left e) -> return $ Left e (Right u) -> A.saveUser (u { userLoginCount = 99 }) failMsg = "saveUser: I expected to success since I'm saving a " ++ "valid user, but I didn't." ------------------------------------------------------------------------------ testMarkAuthFail :: Test testMarkAuthFail = testCase "successful markAuthFail call" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg) res -- Lot of destructuring here, but the idea is to test if -- failedLoginCount increased by 1. hdl :: Handler App App Bool hdl = with auth $ do user <- A.loginByUsername "foo" (ClearText "foo") True case user of (Left _) -> return False (Right u) -> let failCount = userFailedLoginCount u in do res <- A.markAuthFail u either (\_ -> return False) (\u' -> return $ userFailedLoginCount u' == failCount + 1) res failMsg = "markAuthFail: I expected to increase the userFailedLoginCount, " ++ "but I didn't." ------------------------------------------------------------------------------ testMarkAuthFailLockedOut :: Test testMarkAuthFailLockedOut = testCase "markAuthFail lockedOut" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isLockedOut) res hdl :: Handler App App (Either AuthFailure AuthUser) hdl = with auth $ do user <- A.loginByUsername "bar" (ClearText "bar") True case user of (Left e) -> return $ Left e (Right u) -> let u' = u {userFailedLoginCount = 99} in do modify (\s -> s { A.lockout = Just (5, 1000000) }) A.markAuthFail u' failMsg = "markAuthFail: I expected the user to be LockedOut, " ++ "but he didn't." isLockedOut :: Either AuthFailure AuthUser -> Bool isLockedOut (Left _) = False isLockedOut (Right u) = isJust $ userLockedOutUntil u ------------------------------------------------------------------------------ testMarkAuthSuccess :: Test testMarkAuthSuccess = testCase "successful markAuthSuccess call" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg) res hdl :: Handler App App Bool hdl = with auth $ do user <- A.loginByUsername "foo" (ClearText "foo") True case user of (Left _) -> return False (Right u) -> let count = userLoginCount u in do res <- A.markAuthSuccess u either (\_ -> return False) (\u' -> return $ userLoginCount u' == count + 1) res failMsg = "markAuthSuccess: I expected to increase the userLoginCount, " ++ "but I didn't." ------------------------------------------------------------------------------ testCheckPasswordAndLoginOK :: Test testCheckPasswordAndLoginOK = testCase "checkPasswordAndLogin OK" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isRight) res hdl :: Handler App App (Either AuthFailure AuthUser) hdl = with auth $ do let pwd = ClearText "foo" res <- A.loginByUsername "foo" pwd False either (return . Left) (`A.checkPasswordAndLogin` pwd) res failMsg = "checkPasswordAndLogin: I expected to succeed " ++ "but I didn't." ------------------------------------------------------------------------------ testCheckPasswordAndLoginKO :: Test testCheckPasswordAndLoginKO = testCase "checkPasswordAndLogin KO" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isLeft) res hdl :: Handler App App (Either AuthFailure AuthUser) hdl = with auth $ do let pwd = ClearText "wrongpass" res <- A.loginByUsername "foo" pwd False either (return . Left) (`A.checkPasswordAndLogin` pwd) res failMsg = "checkPasswordAndLogin: I expected to succeed " ++ "but I didn't." ------------------------------------------------------------------------------ testAuthenticatePasswordOK :: Test testAuthenticatePasswordOK = testCase "authenticatePassword OK" assertion where assertion :: Assertion assertion = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isNothing) res hdl :: Handler App App (Maybe AuthFailure) hdl = with auth $ do let pwd = ClearText "foo" res <- A.loginByUsername "foo" pwd False either (return . Just) (\u -> return $ A.authenticatePassword u pwd) res failMsg = "authenticatePassword: I expected to succeed " ++ "but I didn't." ------------------------------------------------------------------------------ testAuthenticatePasswordPwdMissing :: Test testAuthenticatePasswordPwdMissing = testCase "authenticatePassword no pwd" a where a :: Assertion a = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isJustFailure PasswordMissing) res hdl :: Handler App App (Maybe AuthFailure) hdl = with auth $ do let pwd = ClearText "foo" res <- A.loginByUsername "foo" pwd False either (return . Just) (\u -> let u' = u { userPassword = Nothing } in return $ A.authenticatePassword u' pwd) res failMsg = "authenticatePassword: I expected to fail due to " ++ " MissingPassword, but I didn't." ------------------------------------------------------------------------------ testAuthenticatePasswordPwdWrong :: Test testAuthenticatePasswordPwdWrong = testCase "authenticatePassword wrong pwd" a where a :: Assertion a = do res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertBool failMsg . isJustFailure IncorrectPassword) res hdl :: Handler App App (Maybe AuthFailure) hdl = with auth $ do let pwd = ClearText "foo" res <- A.loginByUsername "foo" pwd False either (return . Just) (return . flip A.authenticatePassword (ClearText "bar")) res failMsg = "authenticatePassword: I expected to fail due to " ++ " IncorrectPassword, but I didn't." ------------------------------------------------------------------------------ testRegisterUserOK :: Test testRegisterUserOK = testCase "registerUser OK" assertion where assertion :: Assertion assertion = do let hdl = with auth $ A.registerUser "user" "pwd" let params = Map.fromList [("user", ["fizz"]), ("pwd", ["buzz"])] res <- evalHandler Nothing (ST.get "" $ params) hdl appInit either (assertFailure . show) (assertBool failMsg . isRight) res failMsg = "registerUser: I expected to succeed " ++ ", but I didn't." ------------------------------------------------------------------------------ testRegisterUserNoUser :: Test testRegisterUserNoUser = testCase "registerUser no user given" assertion where assertion :: Assertion assertion = do let hdl = with auth $ A.registerUser "user" "pwd" let params = [("user", []), ("pwd", ["buzz"])] res <- evalHandler Nothing (ST.get "" $ Map.fromList params) hdl appInit either (assertFailure . show) (assertBool failMsg . isLeftFailure UsernameMissing) res failMsg = "registerUser: I expected to fail due to UsernameMissing " ++ ", but I didn't." ------------------------------------------------------------------------------ testRegisterUserNoPwd :: Test testRegisterUserNoPwd = testCase "registerUser no pwd given" assertion where assertion :: Assertion assertion = do let hdl = with auth $ A.registerUser "user" "pwd" let params = Map.fromList [("user", ["fizz"]), ("pwd", [])] res <- evalHandler Nothing (ST.get "" $ params) hdl appInit either (assertFailure . show) (assertBool failMsg . isLeftFailure PasswordMissing) res failMsg = "registerUser: I expected to fail due to PasswordMissing " ++ ", but I didn't." ------------------------------------------------------------------------------ testRequireUserOK :: Test testRequireUserOK = testCase "requireUser good handler exec" assertion where assertion :: Assertion assertion = do res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (ST.assertBodyContains "good") res hdl :: Handler App App () hdl = with auth $ do let badHdl = writeText "bad" let goodHdl = writeText "good" A.loginByUsername "foo" (ClearText "foo") True A.requireUser auth badHdl goodHdl ------------------------------------------------------------------------------ testRequireUserKO :: Test testRequireUserKO = testCase "requireUser bad handler exec" assertion where assertion :: Assertion assertion = do res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (ST.assertBodyContains "bad") res hdl :: Handler App App () hdl = with auth $ do let badHdl = writeText "bad" let goodHdl = writeText "good" _ <- A.loginByUsername "doesnotexist" (ClearText "") True A.requireUser auth badHdl goodHdl isRight :: Either a b -> Bool isRight (Left _) = False isRight (Right _) = True isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft (Right _) = False snap-1.1.2.0/test/suite/Snap/Snaplet/Auth/0000755000000000000000000000000000000000000016261 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Auth/SpliceTests.hs0000644000000000000000000000576300000000000021072 0ustar0000000000000000module Snap.Snaplet.Auth.SpliceTests ( tests ) where ------------------------------------------------------------------------------ import Control.Monad (replicateM_, when) import qualified Data.Map as Map import qualified Data.ByteString as BS import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit hiding (Test) ------------------------------------------------------------------------------ import Snap.Core as Core import Snap.Snaplet (with) import qualified Snap.Test as ST import Snap.Snaplet.Test (runHandler, withTemporaryFile) import Snap.Snaplet.Auth (Password(ClearText), createUser, loginByUsername, userISplices) import Snap.Snaplet.Heist (cRender, render, withSplices) import Snap.Snaplet.Test.Common.App (appInit, auth) ------------------------------------------------------------------------------ tests :: Test tests = testGroup "Snap.Snaplet.Auth.SpliceHelpers" [testCase "Render new user page" $ renderNewUser False False ,testCase "New user login render" $ renderNewUser True False ,testCase "New user suspend render" $ renderNewUser False True ,testCase "cRender new user page" $ cRenderNewUser ] ------------------------------------------------------------------------------ renderNewUser :: Bool -> Bool -> Assertion renderNewUser login suspend = withTemporaryFile "users.json" $ do let hdl = with auth $ do usr <- createUser "foo" "foo" _ <- when login $ loginByUsername "foo" (ClearText "foo") False >> return () _ <- when suspend $ replicateM_ 4 $ loginByUsername "foo" (ClearText "wrong") False either (\_ -> Core.modifyResponse $ Core.setResponseStatus 500 "Error") (\u -> withSplices (userISplices u) $ render "userpage") usr res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ cRenderNewUser :: Assertion cRenderNewUser = withTemporaryFile "users.json" $ do let hdl = with auth $ do _ <- createUser "foo" "foo" _ <- loginByUsername "foo" (ClearText "foo") True cRender "userpage" assertValidRes r = do rStr <- ST.responseToString r assertBool "userpage should contain UserName foo splice" $ "UserLogin foo" `BS.isInfixOf` rStr res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) assertValidRes res snap-1.1.2.0/test/suite/Snap/Snaplet/Auth/Tests.hs0000644000000000000000000000125700000000000017724 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Snaplet.Auth.Tests ( tests ) where ------------------------------------------------------------------------------ import Test.Framework (Test, testGroup) import qualified Snap.Snaplet.Auth.Handlers.Tests import qualified Snap.Snaplet.Auth.Types.Tests import qualified Snap.Snaplet.Auth.SpliceTests ------------------------------------------------------------------------------ tests :: Test tests = testGroup "Snap.Snaplet.Auth" [ Snap.Snaplet.Auth.Handlers.Tests.tests , Snap.Snaplet.Auth.SpliceTests.tests , Snap.Snaplet.Auth.Types.Tests.tests ] snap-1.1.2.0/test/suite/Snap/Snaplet/Auth/Types/0000755000000000000000000000000000000000000017365 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Auth/Types/Tests.hs0000644000000000000000000001701700000000000021031 0ustar0000000000000000module Snap.Snaplet.Auth.Types.Tests ( tests ) where ------------------------------------------------------------------------------ import Control.Exception (SomeException, evaluate, try) import Control.Monad (liftM) import Data.Aeson (decode, eitherDecode, encode) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Time import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QCM ------------------------------------------------------------------------------ import qualified Snap.Snaplet.Auth as A import Snap.TestCommon (eqTestCase, ordTestCase, readTestCase, showTestCase) ------------------------------------------------------------------------------ tests :: Test tests = testGroup "Auth type tests" [ testCase "Password serialization" dontSerializeClearText , testCase "Fill in [] roles" deserializeDefaultRoles , testCase "Fail deserialization" failDeserialize , testProperty "AuthFailure show instances" authFailureShows , testProperty "Encrypt agrees with password" encryptByteString , testCase "Reject clear encrypted pw check" rejectCheckClearText , testCase "Test Role Show instance" $ showTestCase (A.Role "a") , testCase "Test Role Read instance" $ readTestCase (A.Role "a") , testCase "Test Role Ord instance" $ ordTestCase (A.Role "a") (A.Role "b") , testCase "Test PW Show instance" $ showTestCase (A.ClearText "pw") , testCase "Test PW Read instance" $ readTestCase (A.ClearText "pw") , testCase "Test PW Ord instance" $ ordTestCase (A.ClearText "a") (A.ClearText "b") , testCase "Test AuthFailure Eq instance" $ eqTestCase A.BackendError A.DuplicateLogin --TODO better as property , testCase "Test AuthFailure Show instance" $ showTestCase A.BackendError -- , testCase "Test AuthFailure Read instance" $ -- readTestCase BackendError -- TODO/NOTE: show . read isn't id for , testCase "Test AuthFailure Ord instance" $ ordTestCase A.BackendError A.DuplicateLogin , testCase "Test UserId Show instance" $ showTestCase (A.UserId "1") , testCase "Test UserId Read instance" $ readTestCase (A.UserId "2") , testCase "Test AuthUser Show instance" $ showTestCase A.defAuthUser , testCase "Test AuthUser Eq instance" $ eqTestCase A.defAuthUser A.defAuthUser ] ------------------------------------------------------------------------------ dontSerializeClearText :: Assertion dontSerializeClearText = do let s = encode (A.ClearText "passwordisnthamster") -- Take the length of the ByteString to force it completely, rather than -- using deepseq; BSL.ByteString lacked an NFData instance until -- bytestring-0.10. r <- try $ evaluate (BSL.length s) >> return s case r of Left e -> (e :: SomeException) `seq` return () Right j -> assertFailure $ "Failed to reject ClearText password serialization: " ++ show j ------------------------------------------------------------------------------ sampleUserJson :: T.Text -> T.Text -> T.Text sampleUserJson reqPair optPair = T.intercalate "," [ "{\"uid\":\"1\"" , "\"login\":\"foo\"" , "\"email\":\"test@example.com\"" , "\"pw\":\"sha256|12|gz47sA0OvbVjos51OJRauQ==|Qe5aU2zAH0gIKHP68KrHJkvvwTvTAqA6UgA33BRpNEo=\"" , reqPair , "\"suspended_at\":null" , "\"remember_token\":\"81160620ef9b64865980c2ab760fcf7f14c06e057cbe1e723cba884a9be05547\"" , "\"login_count\":2" , "\"failed_login_count\":1" , "\"locked_until\":null" , "\"current_login_at\":\"2014-06-24T14:43:51.241Z\"" , "\"last_login_at\":null" , "\"current_ip\":\"127.0.0.1\"" , "\"last_ip\":null" , "\"created_at\":\"2014-06-24T14:43:51.236Z\"" , "\"updated_at\":\"2014-06-24T14:43:51.242Z\"" , "\"reset_token\":null" , "\"reset_requested_at\":null" , optPair , "\"meta\":{}}" ] ------------------------------------------------------------------------------ deserializeDefaultRoles :: Assertion deserializeDefaultRoles = either (\e -> assertFailure $ "Failed user deserialization: " ++ e) (\u -> assertEqual "Roles wasn't initialized to empty" [] (A.userRoles u)) (eitherDecode . BSL.fromChunks . (:[]) . encodeUtf8 $ sampleUserJson "\"activated_at\":null" "\"extra\":null") ------------------------------------------------------------------------------ failDeserialize :: Assertion failDeserialize = do case decode . BSL.fromChunks . (:[]) . encodeUtf8 $ t of Nothing -> return () Just a -> assertFailure $ "Expected deserialization failure, got authUser: " ++ show (a :: A.AuthUser) where t = T.replace "login" "loogin" $ sampleUserJson "\"extra\":null" "\"extra2\":null" ------------------------------------------------------------------------------ authFailureShows :: A.AuthFailure -> Bool authFailureShows ae = length (show ae) > 0 ------------------------------------------------------------------------------ instance QC.Arbitrary A.AuthFailure where arbitrary = do s <- (QC.arbitrary `QC.suchThat` (( > 0 ) . length)) tA <- QC.arbitrary tB <- QC.arbitrary let t = UTCTime (ModifiedJulianDay tA) (realToFrac (tB :: Double)) QC.oneof $ map return [A.AuthError s, A.BackendError ,A.DuplicateLogin, A.EncryptedPassword ,A.IncorrectPassword, A.LockedOut t ,A.PasswordMissing, A.UsernameMissing ,A.UserNotFound ] ------------------------------------------------------------------------------ encryptByteString :: QC.Property encryptByteString = QCM.monadicIO testStringEq where clearPw = BS.pack `liftM` (QC.arbitrary `QC.suchThat` ((>0) . length)) testStringEq = QCM.forAllM clearPw $ \s -> do ePW <- A.Encrypted `liftM` (QCM.run $ A.encrypt s) let cPW = A.ClearText s {- ePW' <- QCM.run $ encryptPassword (ClearText s) QCM.assert $ (checkPassword cPW ePW && checkPassword cPW cPW && checkPassword ePW ePW') --TODO/NOTe: This fails. Surpsising? Encrypt twice and get two different password hashes -} QCM.assert $ (A.checkPassword cPW ePW && A.checkPassword cPW (A.ClearText s)) ------------------------------------------------------------------------------ rejectCheckClearText :: Assertion rejectCheckClearText = do let b = A.checkPassword (A.Encrypted "") (A.ClearText "") r <- try $ b `seq` return b case r of Left e -> (e :: SomeException) `seq` return () Right _ -> assertFailure "checkPassword should not accept encripted-clear pair" snap-1.1.2.0/test/suite/Snap/Snaplet/Config/0000755000000000000000000000000000000000000016565 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Config/Tests.hs0000644000000000000000000000635400000000000020233 0ustar0000000000000000module Snap.Snaplet.Config.Tests where ------------------------------------------------------------------------------ import Control.Concurrent import Control.Concurrent.Async import Control.Monad import qualified Data.ByteString.Char8 as BS import qualified Data.Configurator.Types as C import Data.Function import qualified Data.Map as Map #if !MIN_VERSION_base(4,11,0) import Data.Semigroup import Data.Monoid hiding ((<>)) #else import Data.Monoid #endif import Data.Typeable import System.Environment ------------------------------------------------------------------------------ import Snap.Core import Snap.Http.Server.Config import Snap.Snaplet import Snap.Snaplet.Config import Snap.Snaplet.Heist import Snap.Snaplet.Test.Common.App import Snap.Snaplet.Internal.Initializer import qualified Snap.Test as ST import Snap.Snaplet.Test import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck import Test.HUnit hiding (Test) ------------------------------------------------------------------------------ configTests :: Test configTests = testGroup "Snaplet Config" [ testProperty "Monoid left identity" monoidLeftIdentity , testProperty "Monoid right identity" monoidRightIdentity , testProperty "Monoid associativity" monoidAssociativity , testCase "Verify Typeable instance" verTypeable -- , testCase "Config options used" appConfigGetsToConfig ] newtype ArbAppConfig = ArbAppConfig { unArbAppConfig :: AppConfig } instance Show ArbAppConfig where show (ArbAppConfig (AppConfig a)) = "ArbAppConfig (AppConfig " ++ show a ++ ")" instance Eq ArbAppConfig where a == b = ((==) `on` (appEnvironment . unArbAppConfig)) a b instance Arbitrary ArbAppConfig where arbitrary = liftM (ArbAppConfig . AppConfig) arbitrary instance Semigroup ArbAppConfig where a <> b = ArbAppConfig $ ((<>) `on` unArbAppConfig) a b instance Monoid ArbAppConfig where mempty = ArbAppConfig mempty #if !MIN_VERSION_base(4,11,0) mappend = (<>) #endif monoidLeftIdentity :: ArbAppConfig -> Bool monoidLeftIdentity a = mempty <> a == a monoidRightIdentity :: ArbAppConfig -> Bool monoidRightIdentity a = a <> mempty == a monoidAssociativity :: ArbAppConfig -> ArbAppConfig -> ArbAppConfig -> Bool monoidAssociativity a b c = (a <> b) <> c == a <> (b <> c) ------------------------------------------------------------------------------ verTypeable :: Assertion verTypeable = assertEqual "Unexpected Typeable behavior" #if MIN_VERSION_base(4,7,0) "AppConfig" #else "Snap.Snaplet.Config.AppConfig" #endif (show . typeOf $ (undefined :: AppConfig)) ------------------------------------------------------------------------------ appConfigGetsToConfig :: Assertion appConfigGetsToConfig = do opts <- completeConfig =<< commandLineAppConfig defaultConfig :: IO (Config Snap AppConfig) a <- async . withArgs ["-p", "8001","-e","otherEnv"] $ serveSnaplet opts appInit threadDelay 500000 cancel a b <- async . withArgs ["--environment","devel"] $ serveSnaplet defaultConfig appInit threadDelay 500000 cancel b --TODO - Don't just run the server to touch the config code. Check some values snap-1.1.2.0/test/suite/Snap/Snaplet/Heist/0000755000000000000000000000000000000000000016434 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Heist/Tests.hs0000644000000000000000000003260000000000000020073 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.Heist.Tests where ------------------------------------------------------------------------------ import Control.Applicative import Control.Monad (join) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Char8 as BSC import Data.List (isInfixOf) import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Text as T import Test.HUnit (Assertion, assertBool, assertFailure) import qualified Test.Framework as F import Test.Framework.Providers.HUnit (testCase) ------------------------------------------------------------------------------ import Data.Map.Syntax ((##)) import qualified Heist as H import qualified Heist.Interpreted as I import Snap.Snaplet (with) import qualified Snap.Test as ST import Snap.TestCommon (expectException) import Snap.Snaplet.Test (evalHandler, runHandler) import qualified Snap.Snaplet.Heist as HS import qualified Snap.Snaplet.Heist.Compiled as C import qualified Snap.Snaplet.Heist.Interpreted as I import Snap.Snaplet.Test.Common.App (appInit, appInit', heist) import qualified Text.XmlHtml as XML heistTests :: F.Test heistTests = F.testGroup "Snap.Snaplet.Heist" [testCase "Load templates" addTemplatesOK ,testCase "Get Heist state" assertHasTemplates ,testCase "Handler with heist state" accessibleHeistState ,testCase "gRender a template" gSimpleRender -- ,testCase "gRender another template" gSimpleRenderAnother -- TODO investigate ,testCase "cRender a template" (simpleRender False) ,testCase "Render a template" (simpleRender True) ,testCase "gRenderAs a small template" gSimpleRenderAs ,testCase "cRenderAs a template" (simpleRenderAs False) ,testCase "renderAs a template" (simpleRenderAs True) ,testCase "gServe existing template" gSimpleHeistServeOK ,testCase "cServe templates" (simpleHeistServeOK False) ,testCase "serve templates" (simpleHeistServeOK True) ,testCase "gHeistServe underscore template" gSimpleHeistServeUnd ,testCase "gHeistServe missing template" gSimpleHeistServeMissing ,testCase "gHeistServeSingle template" gSimpleHeistServeSingle ,testCase "cHeistServeSingle template" (simpleHeistServeSingle False) ,testCase "heistServeSingle template" (simpleHeistServeSingle True) ,testCase "gHeistServeSingle underscored template" gSimpleHeistServeSingleUnd ,testCase "gHeistServeSingle missing template" gSimpleHeistServeSingleMissing ,testCase "Choose compiled mode" chooseCompiled ,testCase "Choose interpreted mode" chooseInterpreted ,testCase "Render with splices" fooRenderWith ,testCase "Recognize withSplices" seeLocalSplices ,testCase "Recognize heistLocal" seeLocalState ,testCase "cRender with compiled module" compiledModuleRender ,testCase "cRenderAs compiled module" compiledModuleRenderAs ,testCase "cHeistServe a template" compiledModuleServe ,testCase "cHeistServeSingle a template" compiledModuleServeOne ] ------------------------------------------------------------------------------ addTemplatesOK :: Assertion addTemplatesOK = do let hdl = with heist $ I.render "foopage" res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (ST.assertSuccess) res ------------------------------------------------------------------------------ assertHasTemplates :: Assertion assertHasTemplates = do let hdl = with heist $ do s <- HS.getHeistState t <- return $ H.templateNames s sp <- return $ H.spliceNames s sc <- return $ H.compiledSpliceNames s liftIO $ putStrLn $ "Templates " ++ unwords (map show t) liftIO $ putStrLn $ "Splices: " ++ unwords (map show sp) liftIO $ putStrLn $ "Compiled splices: " ++ unwords (map show sc) return $ Set.fromList (map head t) res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit assertBool "templateNames include foopage, barpage, bazpage" $ (Right (Set.fromList [])) == (Set.difference (Set.fromList ["foopage","barpage","bazpage"]) <$> res) ------------------------------------------------------------------------------ accessibleHeistState :: Assertion accessibleHeistState = do let hdl = with heist . HS.withHeistState $ I.lookupSplice "thisSpliceDoesntExist" res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (ST.assertSuccess) res ------------------------------------------------------------------------------ gSimpleRender :: Assertion gSimpleRender = do let hdl = with heist $ HS.gRender "foopage" res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) ST.assertSuccess res gSimpleRenderAnother :: Assertion gSimpleRenderAnother = do let hdl = with heist $ HS.gRender "bazpage" res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ simpleRender :: Bool -> Assertion simpleRender interp = do let hdl = with heist $ HS.chooseMode (HS.cRender "foopage") (HS.render "foopage") res <- runHandler Nothing (ST.get "" Map.empty) hdl (appInit' interp False) either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ gSimpleRenderAs :: Assertion gSimpleRenderAs = do let hdl = with heist $ HS.gRenderAs "audio/ogg" "foopage" defReq = ST.get "" Map.empty rs = either (return . T.unpack) (\r -> (BSC.unpack <$> ST.responseToString r)) resStr <- join $ rs <$> runHandler Nothing defReq hdl appInit assertBool "gRenderAs should set content to audio/ogg" $ ("audio/ogg" `isInfixOf` resStr) ------------------------------------------------------------------------------ simpleRenderAs :: Bool -> Assertion simpleRenderAs interp = do let hdl = with heist $ HS.chooseMode (HS.cRenderAs "audio/ogg" "foopage") (HS.renderAs "audio/ogg" "foopage") defReq = ST.get "" Map.empty rs = either (return . T.unpack) (\r -> (BSC.unpack <$> ST.responseToString r)) resStr <- join $ rs <$> runHandler Nothing defReq hdl (appInit' interp False) assertBool "renderAs should set content to audio/ogg" $ ("audio/ogg" `isInfixOf` resStr) ------------------------------------------------------------------------------ gSimpleHeistServeOK :: Assertion gSimpleHeistServeOK = do let hdl = with heist HS.gHeistServe res <- runHandler Nothing (ST.get "index" Map.empty) hdl appInit either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ simpleHeistServeOK :: Bool -> Assertion simpleHeistServeOK interp = do let hdl = with heist $ HS.chooseMode HS.cHeistServe HS.heistServe res <- runHandler Nothing (ST.get "foopage" Map.empty) hdl (appInit' interp False) either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ gSimpleHeistServeUnd :: Assertion gSimpleHeistServeUnd = do let hdl = with heist HS.gHeistServe res <- runHandler Nothing (ST.get "_foopage" Map.empty) hdl appInit either (assertFailure . show) ST.assert404 res ------------------------------------------------------------------------------ gSimpleHeistServeMissing :: Assertion gSimpleHeistServeMissing = do let hdl = with heist HS.gHeistServe res <- runHandler Nothing (ST.get "nonexisting" Map.empty) hdl appInit either (assertFailure . show) ST.assert404 res simpleHeistServeSingle :: Bool -> Assertion simpleHeistServeSingle interp = do let hdl = with heist $ HS.chooseMode (HS.cHeistServeSingle "foopage") (HS.heistServeSingle "foopage") res <- runHandler Nothing (ST.get "foopage" Map.empty) hdl (appInit' interp False) either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ -- Serves foopage, despite request for nonexistent gSimpleHeistServeSingle :: Assertion gSimpleHeistServeSingle = do let hdl = with heist $ HS.gHeistServeSingle "foopage" res <- runHandler Nothing (ST.get "nonexistent" Map.empty) hdl appInit either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ -- serveSingle does not filter out underscored templates gSimpleHeistServeSingleUnd :: Assertion gSimpleHeistServeSingleUnd = do let hdl = with heist $ I.heistServeSingle "_foopage" res <- runHandler Nothing (ST.get "_foopage" Map.empty) hdl appInit either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ gSimpleHeistServeSingleMissing :: Assertion gSimpleHeistServeSingleMissing = do let hdl = with heist $ HS.gHeistServeSingle "nonexistent" expectException "gHeistServeSingle failed to throw when serving nonexistent template" (runHandler Nothing (ST.get "nonexistent" Map.empty) hdl appInit) ------------------------------------------------------------------------------ chooseCompiled :: Assertion chooseCompiled = do let hdl = with heist $ HS.chooseMode (liftIO $ return ()) (liftIO $ assertFailure "Should have chosen compiled mode") res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) return res ------------------------------------------------------------------------------ chooseInterpreted :: Assertion chooseInterpreted = do let hdl = with heist $ HS.chooseMode (liftIO $ assertFailure "Should have chosen intpreted mode") (liftIO $ return ()) res <- evalHandler Nothing (ST.get "" Map.empty) hdl (appInit' True False) either (assertFailure . show) return res ------------------------------------------------------------------------------ fooRenderWith :: Assertion fooRenderWith = do let mySplices = ("aSplice" ## I.textSplice "Content") hdl = with heist $ HS.renderWithSplices "foopage" mySplices res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit rStr <- either (const $ return "") ST.responseToString res assertBool "Splice was not spliced in" (BSC.isInfixOf "Content" (rStr :: BSC.ByteString)) ------------------------------------------------------------------------------ seeLocalSplices :: Assertion seeLocalSplices = do let mySplices = do "aSplice" ## I.textSplice "Content" "bSplice" ## I.textSplice "BContent" hdl = with heist $ HS.withSplices mySplices (HS.withHeistState H.spliceNames) res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (\r -> assertBool "Local splices not stored" $ all (`elem` r) ["aSplice","bSplice"]) res ------------------------------------------------------------------------------ seeLocalState :: Assertion seeLocalState = do let hdl = with heist $ HS.heistLocal (I.addTemplate "tinyTemplate" [XML.TextNode "aNode"] Nothing) (HS.withHeistState H.templateNames) res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (\r -> assertBool "Local state template not found" $ "tinyTemplate" `elem` (map head r)) res ------------------------------------------------------------------------------ compiledModuleRender :: Assertion compiledModuleRender = do let hdl = with heist $ C.render "foopage" res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ compiledModuleRenderAs :: Assertion compiledModuleRenderAs = do let hdl = with heist $ C.renderAs "audio/ogg" "foopage" res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit rStr <- either (\_ -> return "") (ST.responseToString) res assertBool "Compiled Heist snaplet response should contain \"audoi/ogg\"" (BSC.isInfixOf "audio/ogg" rStr) ------------------------------------------------------------------------------ compiledModuleServe :: Assertion compiledModuleServe = do let hdl = with heist $ C.heistServe res <- runHandler Nothing (ST.get "foopage" Map.empty) hdl appInit either (assertFailure . show) ST.assertSuccess res ------------------------------------------------------------------------------ compiledModuleServeOne :: Assertion compiledModuleServeOne = do let hdl = with heist $ C.heistServeSingle "foopage" res <- runHandler Nothing (ST.get "foopage" Map.empty) hdl appInit either (assertFailure . show) ST.assertSuccess res snap-1.1.2.0/test/suite/Snap/Snaplet/Internal/LensT/0000755000000000000000000000000000000000000020161 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs0000644000000000000000000000673300000000000021630 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-1.1.2.0/test/suite/Snap/Snaplet/Internal/Lensed/0000755000000000000000000000000000000000000020346 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs0000644000000000000000000000657200000000000022016 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.Lazy 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-1.1.2.0/test/suite/Snap/Snaplet/Internal/RST/0000755000000000000000000000000000000000000017604 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Internal/RST/Tests.hs0000644000000000000000000000325100000000000021243 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) snap-1.1.2.0/test/suite/Snap/Snaplet/Internal/0000755000000000000000000000000000000000000017134 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Internal/Tests.hs0000644000000000000000000001107500000000000020576 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} module Snap.Snaplet.Internal.Tests ( tests, initTest ) where ------------------------------------------------------------------------------ import Control.Lens (makeLenses) import Control.Monad.Trans (MonadIO, liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Text (Text) import Prelude hiding (catch, (.)) import System.Directory (getCurrentDirectory) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.SmallCheck (testProperty) 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-1.1.2.0/test/suite/Snap/Snaplet/Test/Common/0000755000000000000000000000000000000000000017527 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Test/Common/App.hs0000644000000000000000000001341400000000000020606 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} module Snap.Snaplet.Test.Common.App ( App, appInit, appInit', auth, failingAppInit, heist, session, embedded, foo, bar )where ------------------------------------------------------------------------------ import Control.Lens (over) import Control.Monad (when) import Control.Monad.Trans (lift) import Data.Monoid (mempty) ------------------------------------------------------------------------------ import Control.Applicative ((<|>)) import Data.Map.Syntax (( #! ), ( ## )) import Heist (Splices, Template) import Heist.Compiled (Splice, runChildren, withSplices) import Heist.Internal.Types (HeistConfig (..), SpliceConfig (..)) import Heist.Interpreted (addTemplate, textSplice) import Snap.Core (pass, writeText) import Snap.Snaplet (Handler, SnapletInit, addRoutes, embedSnaplet, getLens, getSnapletFilePath, makeSnaplet, nameSnaplet, nestSnaplet, snapletValue, with, wrapSite) import Snap.Snaplet.Auth (AuthManager, AuthSettings, addAuthSplices, authSettingsFromConfig, currentUser, defAuthSettings, userCSplices) import Snap.Snaplet.Auth.Backends.JsonFile (initJsonFileAuthManager) import Snap.Snaplet.Heist (addConfig, addTemplates, heistInit', heistServe, modifyHeistState) import Snap.Snaplet.HeistNoClass (setInterpreted) import Snap.Snaplet.Session.Backends.CookieSession (initCookieSessionManager) import Snap.Snaplet.Test.Common.BarSnaplet import Snap.Snaplet.Test.Common.EmbeddedSnaplet import Snap.Snaplet.Test.Common.FooSnaplet import Snap.Snaplet.Test.Common.Handlers import Snap.Snaplet.Test.Common.Types import Snap.TestCommon (shConfigSplice) import Snap.Util.FileServe (serveDirectory) import Text.XmlHtml (Node (TextNode)) ------------------------------------------------------------------------------ appInit :: SnapletInit App App appInit = appInit' False False ------------------------------------------------------------------------------ appInit' :: Bool -> Bool -> SnapletInit App App appInit' hInterp authConfigFile = makeSnaplet "app" "Test application" Nothing $ do ------------------------------ -- Initial subSnaplet setup -- ------------------------------ hs <- nestSnaplet "heist" heist $ heistInit' "templates" (HeistConfig (mempty {_scCompiledSplices = compiledSplices}) "" True) sm <- nestSnaplet "session" session $ initCookieSessionManager "sitekey.txt" "_session" Nothing (Just (30 * 60)) fs <- nestSnaplet "foo" foo $ fooInit hs bs <- nestSnaplet "" bar $ nameSnaplet "baz" $ barInit hs foo ns <- embedSnaplet "embed" embedded embeddedInit -------------------------------- -- Exercise the Heist snaplet -- -------------------------------- addTemplates hs "extraTemplates" when hInterp $ do modifyHeistState (addTemplate "smallTemplate" aTestTemplate Nothing) setInterpreted hs _lens <- getLens addConfig hs $ mempty { _scInterpretedSplices = do "appsplice" ## textSplice "contents of the app splice" "appconfig" ## shConfigSplice _lens } --------------------------- -- Exercise Auth snaplet -- --------------------------- authSettings <- if authConfigFile then authSettingsFromConfig else return defAuthSettings au <- nestSnaplet "auth" auth $ authInit authSettings addAuthSplices hs auth -- TODO/NOTE: probably not necessary (?) 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) au bs sm ns ------------------------------------------------------------------------------ -- Alternative authInit for tunable settings authInit :: AuthSettings -> SnapletInit App (AuthManager App) authInit settings = initJsonFileAuthManager settings session "users.json" ------------------------------------------------------------------------------ compiledSplices :: Splices (Splice (Handler App App)) compiledSplices = do "userSplice" #! withSplices runChildren userCSplices $ lift $ maybe pass return =<< with auth currentUser ------------------------------------------------------------------------------ fooMod :: FooSnaplet -> FooSnaplet fooMod f = f { fooField = fooField f ++ "z" } ------------------------------------------------------------------------------ aTestTemplate :: Template aTestTemplate = [TextNode "littleTemplateNode"] ------------------------------------------------------------------------------ failingAppInit :: SnapletInit App App failingAppInit = makeSnaplet "app" "Test application" Nothing $ do _ <- error "Error" return undefined snap-1.1.2.0/test/suite/Snap/Snaplet/Test/Common/BarSnaplet.hs0000644000000000000000000000436200000000000022123 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} module Snap.Snaplet.Test.Common.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 Data.Map.Syntax ((##)) import Heist import Heist.Interpreted import Snap.Core import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Snaplet.Test.Common.FooSnaplet import Snap.TestCommon (handlerConfig, shConfigSplice) ------------------------------------------------------------------------------ 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-1.1.2.0/test/suite/Snap/Snaplet/Test/Common/EmbeddedSnaplet.hs0000644000000000000000000000441600000000000023110 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} module Snap.Snaplet.Test.Common.EmbeddedSnaplet where ------------------------------------------------------------------------------ import Control.Lens import Control.Monad.State import qualified Data.Text as T import Prelude hiding ((.)) import System.FilePath.Posix ------------------------------------------------------------------------------ import Data.Map.Syntax (( ## )) import Heist.Interpreted import Snap.Snaplet import Snap.Snaplet.Heist ------------------------------------------------------------------------------ -- 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-1.1.2.0/test/suite/Snap/Snaplet/Test/Common/FooSnaplet.hs0000644000000000000000000000367300000000000022146 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Snap.Snaplet.Test.Common.FooSnaplet where ------------------------------------------------------------------------------ import Control.Lens import Control.Monad.State import Data.Configurator import Data.Maybe import Data.Monoid import qualified Data.Text as T import Prelude hiding (lookup) ------------------------------------------------------------------------------ import Data.Map.Syntax (( ## )) import Heist import Heist.Interpreted import Snap.Core import Snap.Snaplet import Snap.Snaplet.Heist import Snap.TestCommon (handlerConfig, shConfigSplice) ------------------------------------------------------------------------------ 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-1.1.2.0/test/suite/Snap/Snaplet/Test/Common/Handlers.hs0000644000000000000000000000473700000000000021636 0ustar0000000000000000module Snap.Snaplet.Test.Common.Handlers where ------------------------------------------------------------------------------ import Control.Monad.IO.Class (liftIO) import Data.Configurator (lookup) import Data.Maybe (fromJust, fromMaybe) import Data.Text (append, pack) import Data.Text.Encoding (decodeUtf8) ------------------------------------------------------------------------------ import Data.Map.Syntax ((##)) import Heist.Interpreted (textSplice) import Snap.Core (writeText, getParam) import Snap.Snaplet (Handler, getSnapletUserConfig, with) import Snap.Snaplet.Test.Common.FooSnaplet import Snap.Snaplet.Test.Common.Types import Snap.Snaplet.HeistNoClass (renderWithSplices) import Snap.Snaplet.Session (csrfToken, getFromSession, sessionToList, setInSession, withSession) ------------------------------------------------------------------------------- routeWithSplice :: Handler App App () routeWithSplice = do str <- with foo getFooField writeText $ pack $ "routeWithSplice: "++str ------------------------------------------------------------------------------ routeWithConfig :: Handler App App () routeWithConfig = do cfg <- getSnapletUserConfig val <- liftIO $ Data.Configurator.lookup cfg "topConfigField" writeText $ "routeWithConfig: " `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 $ (pack . show) `fmap` sessionToList csrf <- with session $ (pack . show) `fmap` csrfToken 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' = decodeUtf8 x with session $ setInSession "test" x' return x' Nothing -> fromMaybe "" `fmap` with session (getFromSession "test") writeText val snap-1.1.2.0/test/suite/Snap/Snaplet/Test/Common/Types.hs0000644000000000000000000000176200000000000021175 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Snap.Snaplet.Test.Common.Types where ------------------------------------------------------------------------------ import Control.Lens ------------------------------------------------------------------------------ import Snap.Snaplet (Snaplet, subSnaplet) import Snap.Snaplet.Auth (AuthManager) import Snap.Snaplet.Test.Common.BarSnaplet import Snap.Snaplet.Test.Common.EmbeddedSnaplet import Snap.Snaplet.Test.Common.FooSnaplet import Snap.Snaplet.Heist import Snap.Snaplet.Session ------------------------------------------------------------------------------ data App = App { _heist :: Snaplet (Heist App) , _foo :: Snaplet FooSnaplet , _auth :: Snaplet (AuthManager App) , _bar :: Snaplet (BarSnaplet App) , _session :: Snaplet SessionManager , _embedded :: Snaplet EmbeddedSnaplet } $(makeLenses ''App) instance HasHeist App where heistLens = subSnaplet heist snap-1.1.2.0/test/suite/Snap/Snaplet/Test/0000755000000000000000000000000000000000000016277 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/Snaplet/Test/Tests.hs0000644000000000000000000001125000000000000017734 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.Test.Tests ( tests ) where ------------------------------------------------------------------------------ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race) import qualified Data.Map as Map import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit hiding (Test, path) ------------------------------------------------------------------------------ import Snap.Core (readRequestBody, writeLBS, writeText) import Snap.Snaplet.Test (closeSnaplet, evalHandler, evalHandler', getSnaplet, runHandler, runHandler') import Snap.Snaplet.Test.Common.App (appInit, failingAppInit) import qualified Snap.Test as ST ------------------------------------------------------------------------------ tests :: Test tests = testGroup "Snap.Snaplet.Test" [ testRunHandler , testRunHandler' , testEvalHandler , testEvalHandler' , testFailingEvalHandler , testFailingGetSnaplet , readRequestBodyHangIssue -- TODO/NOTE fix ] ------------------------------------------------------------------------------ testRunHandler :: Test testRunHandler = testCase "runHandler simple" assertRunHandler where assertRunHandler :: Assertion assertRunHandler = do let hdl = writeText "Hello!" res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (ST.assertBodyContains "Hello!") res ------------------------------------------------------------------------------ testRunHandler' :: Test testRunHandler' = testCase "runHandler' simple" assertRunHandler' where assertRunHandler' :: Assertion assertRunHandler' = do let hdl = writeText "Hello!" initS <- getSnaplet Nothing appInit case initS of Left err -> assertFailure (show err) Right (a,is) -> do res <- runHandler' a is (ST.get "" Map.empty) hdl closeSnaplet is either (assertFailure . show) (ST.assertBodyContains "Hello!") res ------------------------------------------------------------------------------ testEvalHandler :: Test testEvalHandler = testCase "evalHandler simple" assertEvalHandler where assertEvalHandler :: Assertion assertEvalHandler = do let hdl = return "1+1=2" res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit either (assertFailure . show) (assertEqual "" ("1+1=2"::String)) res ------------------------------------------------------------------------------ testEvalHandler' :: Test testEvalHandler' = testCase "evalHandler' simple" assertEvalHandler' where assertEvalHandler' :: Assertion assertEvalHandler' = do let hdl = return "1+1=2" initS <- getSnaplet Nothing appInit case initS of Left err -> assertFailure (show err) Right (a,is) -> do res <- evalHandler' a is (ST.get "" Map.empty) hdl closeSnaplet is either (assertFailure . show) (assertEqual "" ("1+1=2"::String)) res testFailingEvalHandler :: Test testFailingEvalHandler = testCase "evalHandler failing simple" assertEvalHandler where assertEvalHandler :: Assertion assertEvalHandler = do let hdl = return ("1+1=2" :: String) res <- evalHandler Nothing (ST.get "" Map.empty) hdl failingAppInit case res of Left _ -> assertBool "" True Right _ -> assertFailure "Should have failed in initializer" ------------------------------------------------------------------------------ testFailingGetSnaplet :: Test testFailingGetSnaplet = testCase "getSnaplet failing" assertGetSnaplet where assertGetSnaplet :: Assertion assertGetSnaplet = do initS <- getSnaplet Nothing failingAppInit case initS of Left _ -> assertBool "" True Right _ -> assertFailure "Should have failed in initializer" ------------------------------------------------------------------------------ readRequestBodyHangIssue :: Test readRequestBodyHangIssue = testCase "readRequestBody doesn't hang" assertReadRqBody where assertReadRqBody = do let hdl = readRequestBody 5000 >>= writeLBS res <- race (threadDelay 100000000) (runHandler Nothing (ST.get "" Map.empty) hdl appInit) either (assertFailure . ("readRequestBody timeout" ++) . show) (either (assertFailure . show) ST.assertSuccess) res snap-1.1.2.0/test/suite/Snap/0000755000000000000000000000000000000000000013752 5ustar0000000000000000snap-1.1.2.0/test/suite/Snap/TestCommon.hs0000644000000000000000000000622400000000000016402 0ustar0000000000000000module Snap.TestCommon where ------------------------------------------------------------------------------ import Control.Exception (try, SomeException) import Control.Monad.Trans (lift) import qualified Data.Text as T import qualified GHC.Read as R import Test.HUnit (Assertion, assertFailure, assertBool) import qualified Text.ParserCombinators.ReadPrec as R ------------------------------------------------------------------------------ import Snap.Core import Snap.Snaplet import Snap.Snaplet.Heist import Heist.Interpreted ------------------------------------------------------------------------------ expectException :: String -> IO a -> IO () expectException s m = do r <- try m case r of Left (e::SomeException) -> length (show e) `seq` return () Right _ -> assertFailure s ------------------------------------------------------------------------------ showTestCase :: Show a => a -> Assertion showTestCase a = assertBool "Show instance failed" $ ((showsPrec 5 a) "" == show a) && (showList [a]) "" == "[" ++ show a ++ "]" ------------------------------------------------------------------------------ readTestCase :: (Eq a, Show a, Read a) => a -> Assertion readTestCase a = assertBool "Read instance failed" $ ( ((readsPrec 1) (show a)) == ([(a,"")])) && ((readList ("[" ++ show a ++ "]")) == [([a],"")]) && ((R.readPrec_to_S (R.readPrec) 5) (show a) == [(a,"")]) && ((R.readPrec_to_S (R.readListPrec) 5) ("[" ++ show a ++ "]") == [([a],"")]) ------------------------------------------------------------------------------ ordTestCase :: (Eq a, Ord a) => a -> a -> Assertion ordTestCase a b = assertBool "Ord instance failed" $ low <= high && (if low /= high then low < high && compare low high == LT && high > low else low == high && compare low high == EQ) where low = min a b high = max a b ------------------------------------------------------------------------------ eqTestCase :: (Eq a) => a -> a -> Assertion eqTestCase a b = assertBool "Eq instance failed" $ if a == b then (a /= b) == False else (a /= b) == True ------------------------------------------------------------------------------ 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-1.1.2.0/test/suite/TestSuite.hs0000644000000000000000000001007700000000000015343 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where ------------------------------------------------------------------------------ import Control.Concurrent import Control.Exception (SomeException (..), bracket, catch, finally) import Control.Monad (void) import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.FilePath (()) import System.IO ------------------------------------------------------------------------------ import qualified Blackbox.Tests import Prelude (Bool (False), IO, Int, Maybe (Nothing), Monad (..), Num (..), flip, return, ($), (.), (^)) import Snap.Http.Server (simpleHttpServe) import Snap.Http.Server.Config import Snap.Snaplet import qualified Snap.Snaplet.Auth.Tests import qualified Snap.Snaplet.Config.Tests import qualified Snap.Snaplet.Heist.Tests 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 Snap.Snaplet.Test.Common.App import qualified Snap.Snaplet.Test.Tests import Test.Framework import SafeCWD ------------------------------------------------------------------------------ main :: IO () main = do -- chdir into test/ cwd <- getCurrentDirectory setCurrentDirectory (cwd "test") Blackbox.Tests.remove "snaplets/heist/templates/bad.tpl" Blackbox.Tests.remove "snaplets/heist/templates/good.tpl" {- Why were we removing this? Blackbox.Tests.removeDir "snaplets/foosnaplet" -} -- (tid, mvar) <- inDir False "non-cabal-appdir" startServer (tid, mvar) <- inDir False "." startServer defaultMain [tests] `finally` do setCurrentDirectory cwd 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 , Snap.Snaplet.Heist.Tests.heistTests , Snap.Snaplet.Config.Tests.configTests , Snap.Snaplet.Internal.RST.Tests.tests , Snap.Snaplet.Internal.LensT.Tests.tests , Snap.Snaplet.Internal.Lensed.Tests.tests ] ------------------------------------------------------------------------------ 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 <- forkIOWithUnmask $ \restore -> serve restore mvar (setPort 9753 . setBind "127.0.0.1" $ defaultConfig) appInit threadDelay $ 2*10^(6::Int) return (t, mvar) where gobble m = void m `catch` \(_::SomeException) -> return () serve restore mvar config initializer = flip finally (putMVar mvar ()) $ gobble $ restore $ do hPutStrLn stderr "initializing snaplet" bracket (runSnaplet Nothing initializer) (\(_, _, doCleanup) -> doCleanup) (\(_, handler, _ ) -> do (conf, site) <- combineConfig config handler hPutStrLn stderr "bringing up server" simpleHttpServe conf site)