packages feed

snap 0.7 → 1.1.3.3

raw patch · 109 files changed

Files

+ .ghci view
@@ -0,0 +1,2 @@+:set -XOverloadedStrings+:set -isrc
CONTRIBUTORS view
@@ -4,3 +4,4 @@ Carl Howells <chowells79@gmail.com> Chris Smith <cdsmith@gmail.com> Jurriën Stutterheim <j.stutterheim@me.com>+Alfredo Di Napoli <alfredo.dinapoli@gmail.com>
README.md view
@@ -1,17 +1,16 @@-Snap Framework+Snap Framework [![Hackage Status](https://img.shields.io/hackage/v/snap.svg)](https://hackage.haskell.org/package/snap) ============== -Snap is a web framework for Haskell, based on iteratee I/O (as [popularized by-Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)).  For more-information about Snap, read the `README.SNAP.md` or visit the Snap project-website at http://www.snapframework.com/.+[![GitHub CI](https://github.com/snapframework/snap/workflows/CI/badge.svg)](https://github.com/snapframework/snap/actions) +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 command-line utility for creating initial Snap applications-   * a library allowing Snap applications to recompile actions on the     fly in development mode, with no performance loss in production     mode.@@ -19,17 +18,26 @@   * 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 ============= -The snap tool and library are built using-[Cabal](http://www.haskell.org/cabal/) and-[Hackage](http://hackage.haskell.org/packages/hackage.html). Just run+After you clone the repository, change to the newly created snap directory and+run +    git submodule update --init --recursive+    ./init-sandbox.sh     cabal install -from the `snap` toplevel directory.-+(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 @@ -40,23 +48,24 @@  ## Building the testsuite -To build the test suite, `cd` into the `test/` directory and run+To build the test suite, run -    $ cabal configure+    $ 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 `test/dist/hpc`.+The testsuite generates an `hpc` test coverage report in `dist/hpc`.   ## Roadmap to Understanding Snaplets -1. Read Tutorial.lhs which is in `project_template/tutorial/src`.+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.-
+ changelog.md view
@@ -0,0 +1,34 @@+## 1.1.3.3++ - Update for GHC 9.8+ - Support aeson 2.2++## 1.1.3.2++ - Update for GHC 9.0 through 9.6.2++## 1.1.3.1++ - Update for GHC 8.10++<!-- n.b. where did the rest of the change log entries go?? -->++## 1.1.1.0++### Added++ - GHC 8.4 support++## 1.1.0.0++### Added++ - Support for aeson 1.x+ - GHC 8.2 support+ - New [lookupByEmail](src/Snap/Snaplet/Auth/AuthManager.hs#L62) function in the auth snaplet++## 1.0.0.0+### Removed++ - Removed support for `iteratees` in favor of +   [io-streams](https://hackage.haskell.org/package/io-streams)
+ design.md view
@@ -0,0 +1,129 @@+# 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.+
+ haddock.sh view
@@ -0,0 +1,10 @@+#!/bin/sh++set -x++HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html --css=extra/haddock.css'++cabal haddock $HADDOCK_OPTS --hyperlink-source $@++cp extra/logo.gif dist/doc/html/snap/haskell_icon.gif+cp extra/hscolour.css dist/doc/html/snap/src/
− project_template/barebones/.ghci 
@@ -1,4 +0,0 @@-:set -isrc-:set -hide-package MonadCatchIO-mtl-:set -hide-package monads-fd-:set -XOverloadedStrings
− project_template/barebones/foo.cabal 
@@ -1,29 +0,0 @@-Name:                projname-Version:             0.1-Synopsis:            Project Synopsis Here-Description:         Project Description Here-License:             AllRightsReserved-Author:              Author-Maintainer:          maintainer@example.com-Stability:           Experimental-Category:            Web-Build-type:          Simple-Cabal-version:       >=1.2--Executable projname-  hs-source-dirs: src-  main-is: Main.hs--  Build-depends:-    base >= 4 && < 5,-    bytestring >= 0.9.1 && < 0.10,-    MonadCatchIO-transformers >= 0.2.1 && < 0.3,-    mtl >= 2 && < 3,-    snap-core   == 0.7.*,-    snap-server == 0.7.*--  if impl(ghc >= 6.12.0)-    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-unused-do-bind-  else-    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
− project_template/barebones/log/access.log 
− project_template/barebones/src/Main.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where--import           Control.Applicative-import           Snap.Core-import           Snap.Util.FileServe-import           Snap.Http.Server--main :: IO ()-main = quickHttpServe $-    ifTop (writeBS "hello world") <|>-    route [ ("foo", writeBS "bar")-          , ("echo/:echoparam", echoHandler)-          ] <|>-    dir "static" (serveDirectory ".")--echoHandler :: Snap ()-echoHandler = do-    param <- getParam "echoparam"-    maybe (writeBS "must specify echo/param in URL")-          writeBS param
− project_template/default/.ghci 
@@ -1,4 +0,0 @@-:set -isrc-:set -hide-package MonadCatchIO-mtl-:set -hide-package monads-fd-:set -XOverloadedStrings
− project_template/default/foo.cabal 
@@ -1,51 +0,0 @@-Name:                projname-Version:             0.1-Synopsis:            Project Synopsis Here-Description:         Project Description Here-License:             AllRightsReserved-Author:              Author-Maintainer:          maintainer@example.com-Stability:           Experimental-Category:            Web-Build-type:          Simple-Cabal-version:       >=1.2--Flag development-  Description: Whether to build the server in development (interpreted) mode-  Default: False--Executable projname-  hs-source-dirs: src-  main-is: Main.hs--  Build-depends:-    base >= 4 && < 5,-    bytestring >= 0.9.1 && < 0.10,-    data-lens >= 2.0.1 && < 2.1,-    data-lens-template >= 2.1 && < 2.2,-    heist >= 0.7 && < 0.8,-    MonadCatchIO-transformers >= 0.2.1 && < 0.3,-    mtl >= 2 && < 3,-    snap == 0.7.*,-    snap-core   == 0.7.*,-    snap-server == 0.7.*,-    text >= 0.11 && < 0.12,-    time >= 1.1 && < 1.5,-    xmlhtml == 0.1.*--  if flag(development)-    cpp-options: -DDEVELOPMENT-    -- In development mode, speed is already going to suffer, so skip-    -- the fancy optimization flags.  Additionally, disable all-    -- warnings.  The hint library doesn't give an option to execute-    -- compiled code when there were also warnings, so disabling-    -- warnings allows quicker workflow.-    ghc-options: -threaded -w-  else-    if impl(ghc >= 6.12.0)-      ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2-                   -fno-warn-orphans -fno-warn-unused-do-bind-    else-      ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2-                   -fno-warn-orphans-
− project_template/default/log/access.log 
− project_template/default/log/error.log 
− project_template/default/resources/static/screen.css 
@@ -1,26 +0,0 @@-html {-   padding: 0;-   margin: 0;-   background-color: #ffffff;-   font-family: Verdana, Helvetica, sans-serif;-}-body {-   padding: 0;-   margin: 0;-}-a {-   text-decoration: underline;-}-a :hover {-   cursor: pointer;-   text-decoration: underline;-}-img {-   border: none;-}-#content {-   padding-left: 1em;-}-#info {-   font-size: 60%;-}
− project_template/default/resources/templates/echo.tpl 
@@ -1,13 +0,0 @@-<html>-  <head>-    <title>Echo Page</title>-  </head>-  <body>-    <div id="content">-      <h1>Is there an echo in here?</h1>-    </div>-    <p>You wanted me to say this?</p>-    <p>"<message/>"</p>-    <p><a href="/">Return</a></p>-  </body>-</html>
− project_template/default/resources/templates/index.tpl 
@@ -1,32 +0,0 @@-<html>-  <head>-    <title>Snap web server</title>-    <link rel="stylesheet" type="text/css" href="/screen.css"/>-  </head>-  <body>-    <div id="content">-      <h1>It works!</h1>-      <p>-        This is a simple demo page served using-        <a href="http://snapframework.com/docs/tutorials/heist">Heist</a>-        and the <a href="http://snapframework.com/">Snap</a> web framework.-      </p>-      <p>-        Echo test:-        <a href="/echo/cats">cats</a>-        <a href="/echo/dogs">dogs</a>-        <a href="/echo/fish">fish</a>-      </p>-      <table id="info">-        <tr>-          <td>Config generated at:</td>-          <td><start-time/></td>-        </tr>-        <tr>-          <td>Page generated at:</td>-          <td><current-time/></td>-        </tr>-      </table>-    </div>-  </body>-</html>
− project_template/default/src/Application.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--{---This module defines our application's state type and an alias for its handler-monad.---}--module Application where--import Data.Lens.Template-import Data.Time.Clock--import Snap.Snaplet-import Snap.Snaplet.Heist--data App = App-    { _heist :: Snaplet (Heist App)-    , _startTime :: UTCTime-    }--type AppHandler = Handler App App--makeLens ''App--instance HasHeist App where-    heistLens = subSnaplet heist-
− project_template/default/src/Main.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}--module Main where--import           Control.Exception (SomeException, try)--import qualified Data.Text as T--import           Snap.Http.Server-import           Snap.Snaplet-import           Snap.Core--import           System.IO--import           Site--#ifdef DEVELOPMENT-import           Snap.Loader.Devel-#else-import           Snap.Loader.Prod-#endif---{-|--This is the entry point for this web server application.  It supports-easily switching between interpreting source and running statically-compiled code.--In either mode, the generated program should be run from the root of-the project tree.  When it is run, it locates its templates, static-content, and source files in development mode, relative to the current-working directory.--When compiled with the development flag, only changes to the-libraries, your cabal file, or this file should require a recompile to-be picked up.  Everything else is interpreted at runtime.  There are a-few consequences of this.--First, this is much slower.  Running the interpreter takes a-significant chunk of time (a couple tenths of a second on the author's-machine, at this time), regardless of the simplicity of the loaded-code.  In order to recompile and re-load server state as infrequently-as possible, the source directories are watched for updates, as are-any extra directories specified below.--Second, the generated server binary is MUCH larger, since it links in-the GHC API (via the hint library).--Third, and the reason you would ever want to actually compile with-development mode, is that it enables a faster development cycle. You-can simply edit a file, save your changes, and hit reload to see your-changes reflected immediately.--When this is compiled without the development flag, all the actions-are statically compiled in.  This results in faster execution, a-smaller binary size, and having to recompile the server for any code-change.---}-main :: IO ()-main = do-    -- depending on the version of loadSnapTH in scope, this either-    -- enables dynamic reloading, or compiles it without.  The last-    -- argument to loadSnapTH is a list of additional directories to-    -- watch for changes to trigger reloads in development mode.  It-    -- doesn't need to include source directories, those are picked up-    -- automatically by the splice.-    (conf, site, cleanup) <- $(loadSnapTH [| getConf |]-                                          'getActions-                                          ["resources/templates"])--    _ <- try $ httpServe conf $ site :: IO (Either SomeException ())-    cleanup----- | This action loads the config used by this application.  The--- loaded config is returned as the first element of the tuple--- produced by the loadSnapTH Splice.  The type is not solidly fixed,--- though it must be an IO action that produces the same type as--- 'getActions' takes.  It also must be an instance of Typeable.  If--- the type of this is changed, a full recompile will be needed to--- pick up the change, even in development mode.------ This action is only run once, regardless of whether development or--- production mode is in use.-getConf :: IO (Config Snap ())-getConf = commandLineConfig defaultConfig----- | This function generates the the site handler and cleanup action--- from the configuration.  In production mode, this action is only--- run once.  In development mode, this action is run whenever the--- application is reloaded.------ Development mode also makes sure that the cleanup actions are run--- appropriately before shutdown.  The cleanup action returned from--- loadSnapTH should still be used after the server has stopped--- handling requests, as the cleanup actions are only automatically--- run when a reload is triggered.------ This sample doesn't actually use the config passed in, but more--- sophisticated code might.-getActions :: Config Snap () -> IO (Snap (), IO ())-getActions _ = do-    (msgs, site, cleanup) <- runSnaplet app-    hPutStrLn stderr $ T.unpack msgs-    return (site, cleanup)
− project_template/default/src/Site.hs 
@@ -1,92 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-|--This is where all the routes and handlers are defined for your site. The-'app' function is the initializer that combines everything together and-is exported by this module.---}--module Site-  ( app-  ) where--import           Control.Applicative-import           Control.Monad.Trans-import           Control.Monad.State-import           Data.ByteString (ByteString)-import           Data.Maybe-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import           Data.Time.Clock-import           Snap.Core-import           Snap.Snaplet-import           Snap.Snaplet.Heist-import           Snap.Util.FileServe-import           Text.Templating.Heist-import           Text.XmlHtml hiding (render)--import           Application------------------------------------------------------------------------------------ | Renders the front page of the sample site.------ The 'ifTop' is required to limit this to the top of a route.--- Otherwise, the way the route table is currently set up, this action--- would be given every request.-index :: Handler App App ()-index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index"-  where-    indexSplices =-        [ ("start-time",   startTimeSplice)-        , ("current-time", currentTimeSplice)-        ]------------------------------------------------------------------------------------ | For your convenience, a splice which shows the start time.-startTimeSplice :: Splice AppHandler-startTimeSplice = do-    time <- lift $ gets _startTime-    return $ [TextNode $ T.pack $ show $ time]------------------------------------------------------------------------------------ | For your convenience, a splice which shows the current time.-currentTimeSplice :: Splice AppHandler-currentTimeSplice = do-    time <- liftIO getCurrentTime-    return $ [TextNode $ T.pack $ show $ time]------------------------------------------------------------------------------------ | Renders the echo page.-echo :: Handler App App ()-echo = do-    message <- decodedParam "stuff"-    heistLocal (bindString "message" (T.decodeUtf8 message)) $ render "echo"-  where-    decodedParam p = fromMaybe "" <$> getParam p------------------------------------------------------------------------------------ | The application's routes.-routes :: [(ByteString, Handler App App ())]-routes = [ ("/",            index)-         , ("/echo/:stuff", echo)-         , ("", with heist heistServe)-         , ("", serveDirectory "resources/static")-         ]----------------------------------------------------------------------------------- | The application initializer.-app :: SnapletInit App App-app = makeSnaplet "app" "An snaplet example application." Nothing $ do-    sTime <- liftIO getCurrentTime-    h <- nestSnaplet "heist" heist $ heistInit "resources/templates"-    addRoutes routes-    return $ App h sTime--
− project_template/tutorial/.ghci 
@@ -1,4 +0,0 @@-:set -isrc-:set -hide-package MonadCatchIO-mtl-:set -hide-package monads-fd-:set -XOverloadedStrings
− project_template/tutorial/foo.cabal 
@@ -1,30 +0,0 @@-Name:                projname-Version:             0.1-Synopsis:            Project Synopsis Here-Description:         Project Description Here-License:             AllRightsReserved-Author:              Author-Maintainer:          maintainer@example.com-Stability:           Experimental-Category:            Web-Build-type:          Simple-Cabal-version:       >=1.2--Executable projname-  hs-source-dirs: src-  main-is: Tutorial.lhs--  Build-depends:-    base >= 4 && < 5,-    bytestring >= 0.9.1 && < 0.10,-    MonadCatchIO-transformers >= 0.2.1 && < 0.3,-    mtl >= 2 && < 3,-    snap        == 0.7.*,-    snap-core   == 0.7.*,-    snap-server == 0.7.*--  if impl(ghc >= 6.12.0)-    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-unused-do-bind-  else-    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
− project_template/tutorial/log/placeholder 
@@ -1,1 +0,0 @@-placeholder
− project_template/tutorial/src/Part2.lhs 
@@ -1,14 +0,0 @@-> {-# LANGUAGE OverloadedStrings #-}-> module Part2 where--> import           Snap.Snaplet--> data Foo = Foo-> -> data Bar = Bar-> -> fooInit = makeSnaplet "foo" "Foo snaplet" Nothing $ do->     return Foo-> -> barInit h = makeSnaplet "bar" "Bar snaplet" Nothing $ do->     return Bar
− project_template/tutorial/src/Tutorial.lhs 
@@ -1,352 +0,0 @@-What Are Snaplets?-==================--A snaplet is a composable web application.  Snaplets allow you to build-self-contained pieces of functionality and glue them together to make larger-applications.  Here are some of the things provided by the snaplet API:--  - Infrastructure for application state/environment--  - Snaplet initialization, reload, and cleanup--  - Management of filesystem data and automatic snaplet installation--  - Unified config file infrastructure--One example might be a wiki snaplet.  It would be distributed as a haskell-package that would be installed with cabal and would probably include code,-config files, HTML templates, stylesheets, JavaScript, images, etc.  The-snaplet's code would provide the necessary API to let your application-interact seamlessly with the wiki functionality.  When you run your-application for the first time, all of the wiki snaplet's filesystem resources-will automatically be copied into the appropriate places.  Then you will-immediately be able to customize the wiki to fit your needs by editing config-files, providing your own stylesheets, etc.  We will discuss this in more-detail later.--A snaplet can represent anything from backend Haskell infrastructure with no-user facing functionality to a small widget like a chat box that goes in the-corner of a web page to an entire standalone website like a blog or forum.-The possibilities are endless.  A snaplet is a web application, and web-applications are snaplets.  This means that using snaplets and writing-snaplets are almost the same thing, and it's trivial to drop a whole website-into another one.--We're really excited about the possibilities available with snaplets.  In-fact, Snap already ships with snaplets for sessions, authentication, and-templating (with Heist),  This gives you useful functionality out of the box,-and jump starts your own snaplet development by demonstrating some useful-design patterns.  So without further ado, let's get started.--Snaplet Overview-================--The heart of the snaplets infrastructure is state management.  Most nontrivial-pieces of a web app need some kind of state or environment data.  Components-that do not need any kind of state or environment are probably more-appropriate as a standalone library than as a snaplet.--Before we continue, we must clarify an important point.  The Snap web server-processes each request in its own green thread.  This means that each request-will receive a separate copy of the state defined by your application and-snaplets, and modifications to that state only affect the local thread that-generates a single response.  From now on, when we talk about state this is-what we are talking about.  If you need global application state, you have to-use a thread-safe construct such as an MVar or IORef.--This post is written in literate Haskell, so first we need to get imports out-of the way.--> {-# LANGUAGE TemplateHaskell #-}-> {-# LANGUAGE OverloadedStrings #-}-> -> module Main where-> -> import           Data.IORef-> import qualified Data.ByteString.Char8 as B-> import           Data.Maybe-> import           Snap-> import           Snap.Snaplet.Heist-> import           Part2--We start our application by defining a data structure to hold the state.  This-data structure includes the state of all snaplets (wrapped in a Snaplet) used-by our application as well as any other state we might want.--> data App = App->     { _heist       :: Snaplet (Heist App)->     , _foo         :: Snaplet Foo->     , _bar         :: Snaplet Bar->     , _companyName :: IORef B.ByteString->     }->-> makeLenses [''App]--The field names begin with an underscore because of some more complicated-things going on under the hood.  However, all you need to know right now is-that you should prefix things with an underscore and then call `makeLenses`.-This lets you use the names without an underscore in the rest of your-application.--The next thing we need to do is define an initializer.--> appInit :: SnapletInit App App-> appInit = makeSnaplet "myapp" "My example application" Nothing $ do->     hs <- nestSnaplet "heist" heist $ heistInit "templates"->     fs <- nestSnaplet "foo" foo $ fooInit->     bs <- nestSnaplet "" bar $ nameSnaplet "newname" $ barInit foo->     addRoutes [ ("/hello", writeText "hello world")->               , ("/fooname", with foo namePage)->               , ("/barname", with bar namePage)->               , ("/company", companyHandler)->               ]->     wrapHandlers (<|> heistServe)->     ref <- liftIO $ newIORef "fooCorp"->     return $ App hs fs bs ref--For now don't worry about all the details of this code.  We'll work through the-individual pieces one at a time.  The basic idea here is that to initialize an-application, we first initialize each of the snaplets, add some routes, run a-function wrapping all the routes, and return the resulting state data-structure.  This example demonstrates the use of a few of the most common-snaplet functions.--nestSnaplet-------------   -All calls to child snaplet initializer functions must be wrapped in a call to-nestSnaplet.  The first parameter is a URL path segment that is used to prefix-all routes defined by the snaplet.  This lets you ensure that there will be no-problems with duplicate routes defined in different snaplets.  If the foo-snaplet defines a route `/foopage`, then in the above example, that page will-be available at `/foo/foopage`.  Sometimes though, you might want a snaplet's-routes to be available at the top level.  To do that, just pass an empty string-to nestSnaplet as shown above with the bar snaplet.--In our example above, the bar snaplet does something that needs to know about-the foo snaplet.  Maybe foo is a database snaplet and bar wants to store or-read something.  In order to make that happen, it needs to have a "handle" to-the snaplet.  Our handles are whatever field names we used in the App data-structure minus the initial underscore character.  They are automatically-generated by the `makeLenses` function.  For now it's sufficient to think of-them as a getter and a setter combined (to use an OO metaphor).--The second parameter to nestSnaplet is the lens to the snaplet you're nesting.-In order to place a piece into the puzzle, you need to know where it goes.--nameSnaplet--------------The author of a snaplet defines a default name for the snaplet in the first-argument to the makeSnaplet function.  This name is used for the snaplet's-directory in the filesystem.  If you don't want to use the default name, you-can override it with the `nameSnaplet` function.  Also, if you want to have two-instances of the same snaplet, then you will need to use `nameSnaplet` to give-at least one of them a unique name.--addRoutes------------The `addRoutes` function is how an application (or snaplet) defines its-routes.  Under the hood the snaplet infrastructure merges all the routes from-all snaplets, prepends prefixes from `nestSnaplet` calls, and passes the list-to Snap's-[route](http://hackage.haskell.org/packages/archive/snap-core/0.5.1.4/doc/html/Snap-Types.html#v:route)-function.--A route is a tuple of a URL and a handler function that will be called when-the URL is requested.  Handler is a wrapper around the Snap monad that handles-the snaplet's infrastructure.  During initialization, snaplets use the-`Initializer` monad.  During runtime, they use the `Handler` monad.  We'll-discuss `Handler` in more detail later.  If you're familiar with Snap's old-extension system, you can think of it as roughly equivalent to the Application-monad.  It has a `MonadState` instance that lets you access and modify the-current snaplet's state, and a `MonadSnap` instance providing the-request-processing functions defined in Snap.Types.--wrapHandlers---------------`wrapHandlers` allows you to apply an arbitrary `Handler` transformation to-the top-level handler.  This is useful if you want to do some generic-processing at the beginning or end of every request.  For instance, a session-snaplet might use it to touch a session activity token before routing happens.-It could also be used to implement custom logging.  The example above uses it-to define heistServe (provided by the Heist snaplet) as the default handler to-be tried if no other handler matched.  This may seem like an easy way to define-routes, but if you string them all together in this way each handler will be-evaluated sequentially and you'll get O(n) time complexity, whereas routes-defined with `addRoutes` have O(log n) time complexity.  Therefore, in a-real-world application you would probably want to have `("", heistServe)` in-the list passed to `addRoutes`.--with-------The last unfamiliar function in the example is `with`.  Here it accompanies a-call to the function `namePage`.  `namePage` is a simple example handler and-looks like this.--> namePage :: Handler b v ()-> namePage = do->     mname <- getSnapletName->     writeText $ fromMaybe "This shouldn't happen" mname--This function is a generic handler that gets the name of the current snaplet-and writes it into the response with the `writeText` function defined by the-snap-core project.  The type variables 'b' and 'v' indicate that this function-will work in any snaplet with any base application.  The 'with' function is-used to run `namePage` in the context of the snaplets foo and bar for the-corresponding routes.  --Site Reloading-----------------Snaplet Initializers serve dual purpose as both initializers and reloaders.-Reloads are triggered by a special handler that is bound to the-`/admin/reload` route.  This handler re-runs the site initializer and if it is-successful, loads the newly generated in-memory state.  To prevent denial of-service attacks, the reload route is only accessible from localhost.--If there are any errors during reload, you would naturally want to see them in-the HTTP response returned by the server.  However, when these same-initializers are run when you first start your app, you will want to see-status messages printed to the console.  To make this possible we provide the-`printInfo` function.  You should use it to output any informational messages-generated by your initializers.  If you print directly to standard output or-standard error, then those messages will not be available in your browser when-you reload the site.--Working with state---------------------`Handler b v` has a `MonadState v` instance.  This means that you can access-all your snaplet state through the get, put, gets, and modify functions that-are probably familiar from the state monad.  In our example application we-demonstrate this with `companyHandler`.--> companyHandler :: Handler App App ()-> companyHandler = method GET getter <|> method POST setter->   where->     getter = do->         nameRef <- gets _companyName->         name <- liftIO $ readIORef nameRef->         writeBS name->     setter = do->         mname <- getParam "name"->         nameRef <- gets _companyName->         liftIO $ maybe (return ()) (writeIORef nameRef) mname->         getter--If you set a GET request to `/company`, you'll get the string "fooCorp" back.-If you send a POST request, it will set the IORef held in the `_companyName`-field in the `App` data structure to the value of the `name` field.  Then it-calls the getter to return that value back to you so you can see it was-actually changed.  Again, remember that this change only persists across-requests because we used an IORef.  If `_companyName` was just a plain string-and we had used modify, the changed result would only be visible in the rest-of the processing for that request.--The Heist Snaplet-=================--The astute reader might ask why there is no `with heist` in front of the call-to `heistServe`.  And indeed, that would normally be the case.  But we decided-that an application will never need more than one instance of a Heist snaplet.-So we provided a type class called `HasHeist` that allows an application to-define the global reference to its Heist snaplet by writing a `HasHeist`-instance.  In this example we define the instance as follows:--> instance HasHeist App where heistLens = subSnaplet heist--Now all we need is a simple main function to serve our application.--> main :: IO ()-> main = serveSnaplet defaultConfig appInit--This completes a full working application.  We did leave out a little dummy-code for the Foo and Bar snaplets.  This code is included in Part2.hs.  For-more information look in our [API-documentation](http://hackage.haskell.org/packages/archive/snap/0.6.0.2/doc/html/Snap-Snaplet.html).-No really, that wasn't a joke.  The API docs are written as prose.  It is-written to be very easy to read, while having the benefit of including all the-actual type signatures.--Filesystem Data and Automatic Installation-==========================================--Some snaplets will have data stored in the filesystem that should be installed-into the directory of any project that uses it.  Here's an example of what a-snaplet filesystem layout might look like:--    foosnaplet/-      |-- *snaplet.cfg*-      |-- db.cfg-      |-- public/-          |-- stylesheets/-          |-- images/-          |-- js/-      |-- *snaplets/*-          |-- subsnaplet1/-          |-- subsnaplet2/-      |-- templates/--Only the starred items are actually enforced by current code, but we want to-establish the others as a convention.  The file snaplet.cfg is automatically-read by the snaplet infrastructure.  It is available to you via the-`getSnapletUserConfig` function.  Config files use the format defined by Bryan-O'Sullivan's excellent [configurator-package](http://hackage.haskell.org/package/configurator).  In this example,-the user has chosen to put db config items in a separate file and use-configurator's import functionality to include it in snaplet.cfg.  If-foosnaplet uses `nestSnaplet` or `embedSnaplet` to include any other snaplets,-then filesystem data defined by those snaplets will be included in-subdirectories under the `snaplets/` directory.--So how do you tell the snaplet infrastructure that your snaplet has filesystem-data that should be installed?  Look at the definition of appInit above.  The-third argument to the makeSnaplet function is where we specify the filesystem-directory that should be installed.  That argument has the type `Maybe (IO-FilePath)`.  In this case we used `Nothing` because our simple example doesn't-have any filesystem data.  As an example, let's say you are creating a snaplet-called killerapp that will be distributed as a hackage project called-snaplet-killerapp.  Your project directory structure will look something like-this:--    snaplet-killerapp/-      |-- resources/-      |-- snaplet-killerapp.cabal-      |-- src/--All of the files and directories listed above under foosnaplet/ will be in-resources/.  Somewhere in the code you will define an initializer for the-snaplet that will look like this:--    killerInit = makeSnaplet "killerapp" "42" (Just dataDir) $ do--The primary function of Cabal is to install code.  But it has the ability to-install data files and provides a function called `getDataDir` for retrieving-the location of these files.  Since it returns a different result depending on-what machine you're using, the third argument to `makeSnaplet` has to be `Maybe-(IO FilePath)` instead of the more natural pure version.  To make things more-organized, we use the convention of putting all your snaplet's data files in a-subdirectory called resources.  So we need to create a small function that-appends `/resources` to the result of `getDataDir`.--    import Paths_snaplet_killerapp-    dataDir = liftM (++"/resources") getDataDir--If our project is named snaplet-killerapp, the `getDataDir` function is-defined in the module Paths_snaplet_killerapp, which we have to import.  To-make everything work, you have to tell Cabal about your data files by-including a section like the following in snaplet-killerapp.cabal:--    data-files:-      resources/snaplet.cfg,-      resources/public/stylesheets/style.css,-      resources/templates/page.tpl--Now whenever your snaplet is used, its filesystem data will be automagically-copied into the local project that is using it, whenever the application is-run and it sees that the files don't already exist.-
+ runTestsAndCoverage.sh view
@@ -0,0 +1,81 @@+#!/bin/sh++set -e++# # All directory variables relative to project root+# DIR=dist-newstyle/hpc+# +# SUITE=./dist-newstyle/build/x86_64-osx/ghc-8.2.2/snap-1.1.1.0/t/testsuite/build/testsuite/testsuite+# +# if [ -z "$DEBUG" ]; then+#     export DEBUG=snap-testsuite+# fi+# +# rm -f testsuite.tix+# rm -rf "$DIR"+# mkdir -p "$DIR"+# +# if [ ! -f $SUITE ]; then+#     cat <<EOF+# Testsuite executable not found, please run:+#     cabal install --enable-tests --only-dependencies+#     cabal configure --enable-tests+#     cabal new-build --enable-tests+# EOF+#     exit;+# fi+# +# # cabal new-run testsuite+# $SUITE $*++EXCLUDES='Main+Snap+Blackbox.App+Blackbox.BarSnaplet+Blackbox.Common+Blackbox.EmbeddedSnaplet+Blackbox.FooSnaplet+Blackbox.Tests+Blackbox.Types+Paths_snap+Snap.Snaplet.Auth.Handlers.Tests+Snap.Snaplet.Auth.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.Heist.Tests+Snap.Snaplet.Internal.Lensed.Tests+Snap.Snaplet.Internal.LensT.Tests+Snap.Snaplet.Internal.RST.Tests+Snap.Snaplet.Internal.Tests+Snap.TestCommon+Snap.Snaplet.Test.App+Snap.Snaplet.Test.Tests+Snap.Snaplet.Auth.SpliceTests+Snap.Snaplet.Auth.Types.Tests+Snap.Snaplet.Config.App+Snap.Snaplet.Config.Tests+'++EXCL=""++for m in $EXCLUDES; do+    EXCL="$EXCL --exclude=$m"+done++rm -f test/snaplets/heist/templates/bad.tpl+rm -f test/snaplets/heist/templates/good.tpl+rm -fr test/non-cabal-appdir/snaplets/foosnaplet # TODO++cp ./dist-newstyle/build/x86_64-osx/ghc-8.2.2/snap-1.1.1.0/hpc/vanilla/tix/testsuite/testsuite.tix .++# TODO - actually send results to /dev/null when hpc kinks are fully removed+hpc markup $EXCL --destdir=$DIR testsuite # >/dev/null 2>&1++cat <<EOF++Test coverage report written to $HTMLDIR.+EOF
snap.cabal view
@@ -1,194 +1,289 @@+cabal-version:  2.2 name:           snap-version:        0.7-synopsis:       Snap: A Haskell Web Framework: project starter executable and glue code library-description:    Snap Framework project starter executable and glue code library-license:        BSD3+version:        1.1.3.3+synopsis:       Top-level package for the Snap Web Framework+description:+    This is the top-level package for the official Snap Framework libraries.+    It includes:+    .+    * The Snaplets API+    .+    * Snaplets for sessions, authentication, and templates+    .+    To get started, issue the following sequence of commands:+    .+    @$ cabal install snap snap-templates+    $ mkdir myproject+    $ cd myproject+    $ snap init@+    .+    If you have trouble or any questions, see our FAQ page+    (<http://snapframework.com/faq>) or the documentation+    (<http://snapframework.com/docs>).+    .+    Note: since version 1.0, the \"snap\" executable program for generating+    starter projects is provided by the @snap-templates@ package.++license:        BSD-3-Clause license-file:   LICENSE-author:         Ozgun Ataman, Doug Beardsley, Gregory Collins, Carl Howells, Chris Smith+author:         Ozgun Ataman, Doug Beardsley,+                Gregory Collins, Carl Howells, Chris Smith maintainer:     snap@snapframework.com build-type:     Simple-cabal-version:  >= 1.8 homepage:       http://snapframework.com/+bug-reports:    https://github.com/snapframework/snap/issues category:       Web, Snap +tested-with:+  GHC == 8.8.4+  GHC == 8.10.7+  GHC == 9.0.2+  GHC == 9.2.8+  GHC == 9.4.5+  GHC == 9.6.2+ extra-source-files:+  .ghci,   CONTRIBUTORS,   LICENSE,   README.md,   README.SNAP.md,-  project_template/barebones/.ghci,-  project_template/barebones/foo.cabal,-  project_template/barebones/log/access.log,-  project_template/barebones/src/Main.hs,-  project_template/default/.ghci,-  project_template/default/foo.cabal,-  project_template/default/log/access.log,-  project_template/default/log/error.log,-  project_template/default/resources/static/screen.css,-  project_template/default/resources/templates/echo.tpl,-  project_template/default/resources/templates/index.tpl,-  project_template/default/src/Application.hs,-  project_template/default/src/Main.hs,-  project_template/default/src/Site.hs,-  project_template/tutorial/.ghci,-  project_template/tutorial/foo.cabal,-  project_template/tutorial/log/placeholder,-  project_template/tutorial/src/Part2.lhs,-  project_template/tutorial/src/Tutorial.lhs,+  changelog.md,+  design.md,   extra/hscolour.css,   extra/haddock.css,   extra/logo.gif,-  test/snap-testsuite.cabal,-  test/runTestsAndCoverage.sh,-  test/suite/Snap/TestCommon.hs,-  test/suite/TestSuite.hs+  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 -Flag hint-  Description: Support dynamic project reloading via hint-  Default: False+common universal+  default-language: Haskell2010 +  build-depends:+    , base >= 4.5 && < 5++  if !impl(ghc >= 8.0)+    build-depends:+      , semigroups >= 0.16 && < 0.19+      , fail       >= 4.9  && < 4.10++  default-extensions:+    BangPatterns+    CPP+    DeriveDataTypeable+    ExistentialQuantification+    FlexibleContexts+    FlexibleInstances+    GeneralizedNewtypeDeriving+    MultiParamTypeClasses+    NoMonomorphismRestriction+    OverloadedStrings+    PackageImports+    Rank2Types+    RecordWildCards+    ScopedTypeVariables+    TemplateHaskell+    TypeFamilies+    TypeOperators+    TypeSynonymInstances+ Library+  import: universal   hs-source-dirs: src    exposed-modules:-    Snap,-    Snap.Loader.Prod,-    Snap.Loader.Devel,-    Snap.Snaplet,-    Snap.Snaplet.Heist,-    Snap.Snaplet.Auth,-    Snap.Snaplet.Auth.Backends.JsonFile,-    Snap.Snaplet.Session,+    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:-    Data.RBAC.Checker,-    Data.RBAC.Role,-    Data.RBAC.Types,-    Data.RBAC.Internal.Role,-    Data.RBAC.Internal.RoleMap,-    Data.RBAC.Internal.Rule,-    Data.RBAC.Internal.Types,-    Snap.Snaplet.Auth.AuthManager,-    Snap.Snaplet.Auth.Types,-    Snap.Snaplet.Auth.Handlers,-    Snap.Snaplet.Auth.SpliceHelpers,-    Snap.Snaplet.HeistNoClass,-    Snap.Snaplet.Internal.Initializer,-    Snap.Snaplet.Internal.LensT,-    Snap.Snaplet.Internal.Lensed,-    Snap.Snaplet.Internal.RST,+    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.Common,-    Snap.Snaplet.Session.SecureCookie,-    Snap.Snaplet.Session.SessionManager--  if flag(hint)-    other-modules:-      Snap.Loader.Devel.Evaluator,-      Snap.Loader.Devel.Signal,-      Snap.Loader.Devel.TreeWatcher--    cpp-options: -DHINT_ENABLED--    build-depends:-      hint                    >= 0.3.3.1 && < 0.4--  if !os(windows)-    build-depends:-      unix                    >= 2.2.0.0 && < 2.6+    Snap.Snaplet.Session.SecureCookie    build-depends:-    Crypto                    >= 4.2      && < 4.3,-    MonadCatchIO-transformers >= 0.2      && < 0.3,-    aeson                     >= 0.4      && < 0.5,-    attoparsec                >= 0.10     && < 0.11,-    base                      >= 4        && < 5,-    bytestring                >= 0.9.1    && < 0.10,-    cereal                    >= 0.3      && < 0.4,-    clientsession             >= 0.7.3.6  && <0.8,-    configurator              >= 0.1      && < 0.3,-    containers                >= 0.3      && < 0.5,-    directory                 >= 1.0      && < 1.2,-    directory-tree            >= 0.10     && < 0.11,-    data-lens                 >= 2.0.1    && < 2.1,-    data-lens-template        >= 2.1      && < 2.2,-    filepath                  >= 1.1      && < 1.3,-    hashable                  >= 1.1      && < 1.2,-    heist                     >= 0.7      && < 0.8,-    logict                    >= 0.4.2    && < 0.6,-    mtl                       >  2.0      && < 2.1,-    mwc-random                >= 0.8      && < 0.11,-    old-time                  >= 1.0      && < 1.1,-    pwstore-fast              >= 2.2      && < 2.3,-    safe                      >= 0.3      && < 0.4,-    skein                     >= 0.1.0.3  && < 0.2,-    snap-core                 >= 0.7      && < 0.8,-    snap-server               >= 0.7      && < 0.8,-    stm                       >= 2.2      && < 2.3,-    syb                       >= 0.1      && < 0.4,-    template-haskell          >= 2.2      && < 2.7,-    text                      >= 0.11     && < 0.12,-    time                      >= 1.1      && < 1.5,-    transformers              >= 0.2      && < 0.3,-    unordered-containers      >= 0.1.4    && < 0.2,-    utf8-string               >= 0.3      && < 0.4,-    vector                    >= 0.7.1    && < 0.10,-    vector-algorithms         >= 0.4      && < 0.6,-    xmlhtml                   >= 0.1      && < 0.2--  extensions:-    BangPatterns,-    CPP,-    DeriveDataTypeable,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses,-    NoMonomorphismRestriction,-    OverloadedStrings,-    PackageImports,-    Rank2Types,-    ScopedTypeVariables,-    TemplateHaskell,-    TypeFamilies,-    TypeOperators,-    TypeSynonymInstances+    aeson                     >= 0.6      && < 2.3,+    attoparsec                >= 0.10     && < 0.15,+    attoparsec-aeson          >= 2.1.0.0  && < 3.0,+    bytestring                >= 0.9.1    && < 0.13,+    cereal                    >= 0.3      && < 0.6,+    clientsession             >= 0.8      && < 0.10,+    configurator              >= 0.1      && < 0.4,+    containers                >= 0.2      && < 0.8,+    directory                 >= 1.1      && < 1.4,+    directory-tree            >= 0.11     && < 0.13,+    dlist                     >= 0.5      && < 1.1,+    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.5,+    heist                     >= 1.1      && < 1.2,+    lens                      >= 3.7.6    && < 5.3,+    lifted-base               >= 0.2      && < 0.3,+    map-syntax                >= 0.2      && < 0.4,+    monad-control             >= 0.3      && < 1.1,+    mtl                       >= 2.0      && < 2.4,+    mwc-random                >= 0.8      && < 0.16,+    pwstore-fast              >= 2.2      && < 2.5,+    snap-core                 >= 1.0      && < 1.1,+    snap-server               >= 1.0      && < 1.2,+    stm                       >= 2.2      && < 2.6,+    text                      >= 1.1.1.0  && < 2.2,+    time                      >= 1.1      && < 1.14,+    transformers              >= 0.2      && < 0.7,+    transformers-base         >= 0.4      && < 0.5,+    unordered-containers      >= 0.1.4    && < 0.3,+    xmlhtml                   >= 0.1      && < 0.3    if impl(ghc >= 6.12.0)-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+    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 -O2+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields                  -fno-warn-orphans -Executable snap-  hs-source-dirs: src-  main-is: Snap/Starter.hs--  other-modules: Snap.StarterTH+Test-suite testsuite+  import: universal+  hs-source-dirs: src test/suite+  type: exitcode-stdio-1.0+  main-is: TestSuite.hs -  build-depends:-    base                >= 4       && < 5,-    bytestring          >= 0.9.1   && < 0.10,-    containers          >= 0.3     && < 0.5,-    directory           >= 1.0     && < 1.2,-    directory-tree      >= 0.10    && < 0.11,-    filepath            >= 1.1     && < 1.3,-    old-time            >= 1.0     && < 1.1,-    snap-server         >= 0.7     && < 0.8,-    template-haskell    >= 2.2     && < 2.7,-    text                >= 0.11    && < 0.12+  autogen-modules:+    Paths_snap -  ghc-prof-options: -prof -auto-all+  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 -  if impl(ghc >= 6.12.0)-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-orphans -fno-warn-unused-do-bind-  else-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-orphans+  build-depends:+    aeson,+    async                      >= 2.0.1.5  && < 2.3,+    attoparsec,+    attoparsec-aeson,+    bytestring,+    cereal,+    clientsession,+    configurator,+    containers,+    deepseq,+    directory,+    directory-tree,+    dlist,+    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.15,+    smallcheck                 >= 1.1.1    && < 1.3,+    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  source-repository head   type:     git
− src/Data/RBAC/Checker.hs 
@@ -1,223 +0,0 @@-{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.RBAC.Checker where--import           Control.Monad-import           Control.Monad.Logic-import           Control.Monad.Reader-import           Control.Monad.State.Lazy-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.Maybe (fromMaybe, isJust)-import           Data.Text (Text)--import           Data.RBAC.Internal.RoleMap (RoleMap)-import qualified Data.RBAC.Internal.RoleMap as RM-import           Data.RBAC.Internal.Types-import           Data.RBAC.Role----------------------------------------------------------------------------------type RoleBuilder a = StateT RoleMap RoleMonad a----------------------------------------------------------------------------------applyRule :: Role -> Rule -> [Role]-applyRule r (Rule _ f) = f r----------------------------------------------------------------------------------applyRuleSet :: Role -> RuleSet -> [Role]-applyRuleSet r (RuleSet m) = f r-  where-    f = fromMaybe (const []) $ M.lookup (_roleName r) m----------------------------------------------------------------------------------checkUnseen :: Role -> RoleBuilder ()-checkUnseen role = do-    m <- get-    if isJust $ RM.lookup role m then mzero else return ()----------------------------------------------------------------------------------checkSeen :: Role -> RoleBuilder ()-checkSeen = lnot . checkUnseen----------------------------------------------------------------------------------markSeen :: Role -> RoleBuilder ()-markSeen role = modify $ RM.insert role----------------------------------------------------------------------------------isum :: (MonadLogic m, MonadPlus m) => [m a] -> m a-isum l = case l of-            []     -> mzero-            (x:xs) -> x `interleave` isum xs------------------------------------------------------------------------------------ | Given a set of roles to check, and a set of implication rules describing--- how a given role inherits from other roles, this function produces a stream--- of expanded Roles. If a Role is seen twice, expandRoles mzeros.-expandRoles :: [Rule] -> [Role] -> RoleMonad Role-expandRoles rules roles0 = evalStateT (go roles0) RM.empty-  where-    ruleSet = rulesToSet rules--    go roles = isum $ map expandOne roles--    expandOne role = do-        checkUnseen role-        markSeen role-        return role `interleave` go newRoles--      where-        newRoles = applyRuleSet role ruleSet----------------------------------------------------------------------------------hasRole :: Role -> RuleChecker ()-hasRole r = RuleChecker $ do-    ch <- ask-    once $ go ch-  where-    go gen = do-        r' <- lift gen-        if r `matches` r' then return () else mzero----------------------------------------------------------------------------------missingRole :: Role -> RuleChecker ()-missingRole = lnot . hasRole----------------------------------------------------------------------------------hasAllRoles :: [Role] -> RuleChecker ()-hasAllRoles rs = RuleChecker $ do-    ch <- ask-    lift $ once $ go ch $ RM.fromList rs-  where-    go gen !st = do-        mr <- msplit gen-        maybe mzero-              (\(r,gen') -> let st' = RM.delete r st-                            in if RM.null st'-                                 then return ()-                                 else go gen' st')-              mr----------------------------------------------------------------------------------hasAnyRoles :: [Role] -> RuleChecker ()-hasAnyRoles rs = RuleChecker $ do-    ch <- ask-    lift $ once $ go ch-  where-    st = RM.fromList rs-    go gen = do-        mr <- msplit gen-        maybe mzero-              (\(r,gen') -> if isJust $ RM.lookup r st-                                 then return ()-                                 else go gen')-              mr----------------------------------------------------------------------------------runRuleChecker :: [Rule]-               -> [Role]-               -> RuleChecker a-               -> Bool-runRuleChecker rules roles (RuleChecker f) =-    case outs of-      []    -> False-      _     -> True-  where-    (RoleMonad st) = runReaderT f $ expandRoles rules roles-    outs = observeMany 1 st----------------------------------------------------------------------------------mkRule :: Text -> (Role -> [Role]) -> Rule-mkRule = Rule----------------------------------------------------------------------------------implies :: Role -> [Role] -> Rule-implies src dest = Rule (_roleName src)-                        (\role -> if role `matches` src then dest else [])----------------------------------------------------------------------------------impliesWith :: Role -> (HashMap Text RoleValue -> [Role]) -> Rule-impliesWith src f = Rule (_roleName src)-                         (\role -> if src `matches` role-                                     then f $ _roleData role-                                     else [])------------------------------------------------------------------------------------ Testing code follows: TODO: move into test suite---testRules :: [Rule]-testRules = [ "user" `implies` ["guest", "can_post"]-            , "superuser" `implies` [ "user"-                                    , "can_moderate"-                                    , "can_administrate"]-            , "superuser" `implies` [ addRoleData "arg" "*" "with_arg" ]-            , "with_arg" `impliesWith` \dat ->-                maybe [] (\arg -> [addRoleData "arg" arg "dependent_arg"]) $-                      M.lookup "arg" dat-            , "superuser" `implies` [ addRoleData "arg1" "a" $-                                      addRoleData "arg2" "b" "multi_args" ]-            ]--tX :: RuleChecker () -> Bool-tX f = runRuleChecker testRules ["superuser"] f--t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17 :: Bool-t1 = tX $ hasAnyRoles ["guest","userz"]--t2 = tX $ hasAllRoles ["guest","userz"]--t3 = tX $ hasAllRoles ["guest","user"]--t4 = tX $ hasRole "can_administrate"--t5 = tX $ hasRole "lkfdhjkjfhds"--t6 = tX $ do-         hasRole "guest"-         hasRole "superuser"--t7 = tX $ do-         hasRole "zzzzz"-         hasRole "superuser"--t8 = tX $ hasRole $ addRoleData "arg" "*" "dependent_arg"--t9 = tX $ hasRole "multi_args"--t10 = tX $ hasRole $ addRoleData "arg2" "b" "multi_args"--t11 = tX $ hasRole $ addRoleData "arg2" "z" "multi_args"--t12 = tX $ hasAllRoles [addRoleData "arg2" "b" "multi_args"]--t13 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"-                       , addRoleData "arg2" "b" "multi_args" ]--t14 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"-                       , addRoleData "arg2" "aaa" "multi_args" ]--t15 = tX $ missingRole "jflsdkjf"--t16 = tX $ do-          missingRole "fdjlksjlf"-          hasRole "multi_args"--t17 = tX $ missingRole "multi_args"
− src/Data/RBAC/Internal/Role.hs 
@@ -1,81 +0,0 @@-module Data.RBAC.Internal.Role where--import           Control.Monad.ST-import           Data.Hashable-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.String-import           Data.Text (Text)-import qualified Data.Vector as V-import qualified Data.Vector.Algorithms.Merge as VA----------------------------------------------------------------------------------data RoleValue = RoleBool Bool-               | RoleText Text-               | RoleInt Int-               | RoleDouble Double-  deriving (Ord, Eq, Show)---instance IsString RoleValue where-    fromString = RoleText . fromString---instance Hashable RoleValue where-    hashWithSalt salt (RoleBool e)   = hashWithSalt salt e `combine` 7-    hashWithSalt salt (RoleText t)   = hashWithSalt salt t `combine` 196613-    hashWithSalt salt (RoleInt i)    = hashWithSalt salt i `combine` 12582917-    hashWithSalt salt (RoleDouble d) =-        hashWithSalt salt d `combine` 1610612741----------------------------------------------------------------------------------data Role = Role {-      _roleName :: Text-    , _roleData :: HashMap Text RoleValue-    }-  deriving (Eq, Show)---instance IsString Role where-    fromString s = Role (fromString s) M.empty----------------------------------------------------------------------------------toSortedList :: (Ord k, Ord v) => HashMap k v -> [(k,v)]-toSortedList m = runST $ do-    v <- V.unsafeThaw $ V.fromList $ M.toList m-    VA.sort v-    v' <- V.unsafeFreeze v-    return $ V.toList v'----instance Hashable Role where-    hashWithSalt salt (Role nm dat) =-        h $ hashWithSalt salt nm-      where-        h s = hashWithSalt s $ toSortedList dat----------------------------------------------------------------------------------data RoleValueMeta = RoleBoolMeta-                   | RoleTextMeta-                   | RoleEnumMeta [Text]-                   | RoleIntMeta-                   | RoleDoubleMeta---data RoleDataDefinition = RoleDataDefinition {-      _roleDataName        :: Text-    , _roleValueMeta       :: RoleValueMeta-    , _roleDataDescription :: Text-    }---data RoleMetadata = RoleMetadata {-      _roleMetadataName :: Text-    , _roleDescription  :: Text-    , _roleDataDefs     :: [RoleDataDefinition]-    }
− src/Data/RBAC/Internal/RoleMap.hs 
@@ -1,58 +0,0 @@-module Data.RBAC.Internal.RoleMap where--import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.HashSet (HashSet)-import qualified Data.HashSet as S-import           Data.List (find, foldl')-import           Data.Text (Text)--import           Data.RBAC.Role-import           Data.RBAC.Internal.Types---newtype RoleMap = RoleMap (HashMap Text (HashSet Role))----------------------------------------------------------------------------------fromList :: [Role] -> RoleMap-fromList = RoleMap . foldl' ins M.empty-  where-    ins m role =-        M.insertWith S.union (_roleName role) (S.singleton role) m----------------------------------------------------------------------------------lookup :: Role -> RoleMap -> Maybe Role-lookup role (RoleMap m) = find (`matches` role) l-  where-    l = maybe [] S.toList $ M.lookup (_roleName role) m----------------------------------------------------------------------------------delete :: Role -> RoleMap -> RoleMap-delete role (RoleMap m) = RoleMap $ maybe m upd $ M.lookup rNm m-  where-    rNm = _roleName role-    upd s = maybe m-                  (\r -> let s' = S.delete r s-                         in if S.null s'-                              then M.delete rNm m-                              else M.insert rNm s' m)-                  (find (`matches` role) $ S.toList s)----------------------------------------------------------------------------------insert :: Role -> RoleMap -> RoleMap-insert role (RoleMap m) =-    RoleMap $ M.insertWith S.union (_roleName role) (S.singleton role) m----------------------------------------------------------------------------------empty :: RoleMap-empty = RoleMap M.empty----------------------------------------------------------------------------------null :: RoleMap -> Bool-null (RoleMap m) = M.null m
− src/Data/RBAC/Internal/Rule.hs 
@@ -1,31 +0,0 @@-module Data.RBAC.Internal.Rule where--import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.List (foldl')-import           Data.Monoid-import           Data.Text (Text)--import           Data.RBAC.Internal.Role---------------------------------------------------------------------------------data Rule = Rule Text (Role -> [Role])--newtype RuleSet = RuleSet (HashMap Text (Role -> [Role]))--instance Monoid RuleSet where-    mempty = RuleSet M.empty-    (RuleSet m1) `mappend` (RuleSet m2) = RuleSet $ M.foldlWithKey' ins m2 m1-      where-        combine f1 f2 r = f1 r ++ f2 r-        ins m k v       = M.insertWith combine k v m----------------------------------------------------------------------------------ruleToSet :: Rule -> RuleSet-ruleToSet (Rule nm f) = RuleSet $ M.singleton nm f----------------------------------------------------------------------------------rulesToSet :: [Rule] -> RuleSet-rulesToSet = foldl' mappend (RuleSet M.empty) . map ruleToSet
− src/Data/RBAC/Internal/Types.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}--module Data.RBAC.Internal.Types-  ( module Data.RBAC.Internal.Role-  , module Data.RBAC.Internal.Rule-  , RoleMonad(..)-  , RuleChecker(..)-  ) where--import           Control.Applicative-import           Control.Monad.Reader-import           Control.Monad.Logic--import           Data.RBAC.Internal.Role-import           Data.RBAC.Internal.Rule------------------------------------------------------------------------------------ TODO: should the monads be transformers here? If they were, you could check--- more complex predicates here----------------------------------------------------------------------------------newtype RoleMonad a = RoleMonad { _unRC :: Logic a }-  deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic)----------------------------------------------------------------------------------newtype RuleChecker a = RuleChecker (ReaderT (RoleMonad Role) RoleMonad a)-  deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic)-
− src/Data/RBAC/Role.hs 
@@ -1,24 +0,0 @@-module Data.RBAC.Role where--import qualified Data.HashMap.Strict as M-import           Data.RBAC.Internal.Types-import           Data.Text (Text)----------------------------------------------------------------------------------matches :: Role -> Role -> Bool-matches (Role a1 d1) (Role a2 d2) =-    a1 == a2 && dmatch (toSortedList d1) (toSortedList d2)-  where-    dmatch []         _      = True-    dmatch _          []     = False-    dmatch dds@(d:ds) (e:es) =-        case compare d e of-          LT -> False-          EQ -> dmatch ds es-          GT -> dmatch dds es----------------------------------------------------------------------------------addRoleData :: Text -> RoleValue -> Role -> Role-addRoleData k v (Role n d) = Role n $ M.insert k v d
− src/Data/RBAC/Types.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}--module Data.RBAC.Types-  ( Role(..)                    -- fixme: remove (..)-  , RoleValue(..)               -- fixme-  , RoleValueMeta(..)-  , RoleDataDefinition(..)-  , RoleMetadata(..)-  , Rule-  , RuleChecker-  ) where--import Data.RBAC.Internal.Types
src/Snap.hs view
@@ -7,19 +7,11 @@ -}  module Snap-  ( module Control.Applicative-  , module Control.Monad.State-  , module Data.Lens.Common-  , module Data.Lens.Template-  , module Snap.Core+  ( module Snap.Core   , module Snap.Http.Server   , module Snap.Snaplet   ) where -import Control.Applicative-import Control.Monad.State-import Data.Lens.Common-import Data.Lens.Template import Snap.Core import Snap.Http.Server import Snap.Snaplet
− src/Snap/Loader/Devel.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}--- | This module includes the machinery necessary to use hint to load--- action code dynamically.  It includes a Template Haskell function--- to gather the necessary compile-time information about code--- location, compiler arguments, etc, and bind that information into--- the calls to the dynamic loader.-module Snap.Loader.Devel-  ( loadSnapTH-  ) where--#ifdef HINT_ENABLED-import           Control.Monad (liftM2)--import           Data.Char (isAlphaNum)-import           Data.List-import           Data.Maybe (maybeToList)-import           Data.Time.Clock (diffUTCTime, getCurrentTime)-import           Data.Typeable--import           Language.Haskell.Interpreter hiding (lift, liftIO, typeOf)-import           Language.Haskell.Interpreter.Unsafe--import           Language.Haskell.TH--import           System.Environment (getArgs)--import           Snap.Core-import           Snap.Loader.Devel.Signal-import           Snap.Loader.Devel.Evaluator-import           Snap.Loader.Devel.TreeWatcher-#else-import           Language.Haskell.TH-#endif----------------------------------------------------------------------------------- | This function derives all the information necessary to use the--- interpreter from the compile-time environment, and compiles it in--- to the generated code.------ This could be considered a TH wrapper around a function------ > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ()))--- >                        -> [String] -> IO (a, Snap (), IO ())------ with a magical implementation.  The [String] argument is a list of--- directories to watch for updates to trigger a reloading.--- Directories containing code should be automatically picked up by--- this splice.------ The generated splice executes the initialiser once, sets up the--- interpreter for the load function, and returns the initializer's--- result along with the interpreter's proxy handler and cleanup--- actions.  The behavior of the proxy actions will change to reflect--- changes in the watched files, reinterpreting the load function as--- needed and applying it to the initializer result.------ This will handle reloading the application successfully in most--- cases.  The cases in which it is certain to fail are those--- involving changing the types of the initializer or the load--- function, or changing the compiler options required, such as by--- changing/adding dependencies in the project's .cabal file.  In--- those cases, a full recompile will be needed.-loadSnapTH :: Q Exp    -- ^ the initializer expression-           -> Name     -- ^ the name of the load function-           -> [String] -- ^ a list of directories to watch in addition-                       -- to those containing code-           -> Q Exp-#ifndef HINT_ENABLED-loadSnapTH _ _ _ = fail $ "Snap was built without hint support.  Hint " ++-                   "support is necessary for development mode.  " ++-                   "Please reinstall snap with hint support.\n\n " ++-                   "  cabal install snap -fhint\n\n"-#else-loadSnapTH initializer action additionalWatchDirs = do-    args <- runIO getArgs--    let opts = getHintOpts args-        srcPaths = additionalWatchDirs ++ getSrcPaths args--    -- The first line is an extra type check to ensure the arguments-    -- provided have the the correct types-    [| do let _ = $initializer >>= $(varE action)-          v <- $initializer-          (handler, cleanup) <- hintSnap opts actMods srcPaths loadStr v-          return (v, handler, cleanup) |]-  where-    actMods = maybeToList $ nameModule action-    loadStr = nameBase action------------------------------------------------------------------------------------ | Convert the command-line arguments passed in to options for the--- hint interpreter.  This is somewhat brittle code, based on a few--- experimental datapoints regarding the structure of the command-line--- arguments cabal produces.-getHintOpts :: [String] -> [String]-getHintOpts args = removeBad opts-  where-    bad = ["-threaded", "-O"]-    removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad)--    hideAll = filter (== "-hide-all-packages") args--    srcOpts = filter (\x -> "-i" `isPrefixOf` x-                            && not ("-idist" `isPrefixOf` x)) args--    toCopy = filter (not . isSuffixOf ".hs") $-             dropWhile (not . ("-package" `isPrefixOf`)) args-    copy = map (intercalate " ") . groupBy (\_ s -> not $ "-" `isPrefixOf` s)--    opts = hideAll ++ srcOpts ++ copy toCopy------------------------------------------------------------------------------------ | This function extracts the source paths from the compilation args-getSrcPaths :: [String] -> [String]-getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg-  where-    srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x)------------------------------------------------------------------------------------ | This function creates the Snap handler that actually is--- responsible for doing the dynamic loading of actions via hint,--- given all of the configuration information that the interpreter--- needs.  It also ensures safe concurrent access to the interpreter,--- and caches the interpreter results for a short time before allowing--- it to run again.------ Generally, this won't be called manually.  Instead, loadSnapTH will--- generate a call to it at compile-time, calculating all the--- arguments from its environment.-hintSnap :: Typeable a-         => [String] -- ^ A list of command-line options for the interpreter-         -> [String] -- ^ A list of modules that need to be-                     -- interpreted. This should contain only the-                     -- modules which contain the initialization,-                     -- cleanup, and handler actions.  Everything else-                     -- they require will be loaded transitively.-         -> [String] -- ^ A list of paths to watch for updates-         -> String   -- ^ The name of the function to load-         -> a        -- ^ The value to apply the loaded function to-         -> IO (Snap (), IO ())-hintSnap opts modules srcPaths action value =-    protectedHintEvaluator initialize test loader-  where-    witness x = undefined $ x `asTypeOf` value :: HintLoadable--    -- This is somewhat fragile, and probably can be cleaned up with a-    -- future version of Typeable.  For the moment, and-    -- backwards-compatibility, this is the approach being taken.-    witnessModules = map (reverse . drop 1 . dropWhile (/= '.') . reverse) .-                     filter (elem '.') . groupBy typePart . show . typeOf $-                     witness--    typePart x y = (isAlphaNum x && isAlphaNum  y) || x == '.' || y == '.'--    interpreter = do-        loadModules . nub $ modules-        setImports . nub $ "Prelude" : witnessModules ++ modules--        f <- interpret action witness-        return $ f value--    loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter--    formatOnError (Left err) = error $ format err-    formatOnError (Right a) = a--    loader = formatOnError `fmap` protectHandlers loadInterpreter--    initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths--    test (prevTime, ts) = do-        now <- getCurrentTime-        if diffUTCTime now prevTime < 3-            then return True-            else checkTreeStatus ts------------------------------------------------------------------------------------ | Convert an InterpreterError to a String for presentation-format :: InterpreterError -> String-format (UnknownError e)   = "Unknown interpreter error:\r\n\r\n" ++ e-format (NotAllowed e)     = "Interpreter action not allowed:\r\n\r\n" ++ e-format (GhcException e)   = "GHC error:\r\n\r\n" ++ e-format (WontCompile errs) = "Compile errors:\r\n\r\n" ++-    (intercalate "\r\n" $ nub $ map errMsg errs)--#endif
− src/Snap/Loader/Devel/Evaluator.hs 
@@ -1,144 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Loader.Devel.Evaluator-  ( HintLoadable-  , protectedHintEvaluator-  ) where---import Control.Exception-import Control.Monad (when)-import Control.Monad.Trans (liftIO)--import Control.Concurrent (ThreadId, forkIO, myThreadId)-import Control.Concurrent.MVar--import Prelude hiding (catch, init, any)--import Snap.Core (Snap)------------------------------------------------------------------------------------ | A type synonym to simply talking about the type loaded by hint.-type HintLoadable = IO (Snap (), IO ())------------------------------------------------------------------------------------ | Convert an action to generate 'HintLoadable's into Snap and IO--- actions that handle periodic reloading.  The resulting action will--- share initialized state until the next execution of the input--- action.  At this time, the cleanup action will be executed.------ The first two arguments control when recompiles are done.  The--- first argument is an action that is executed when compilation--- starts.  The second is a function from the result of the first--- action to an action that determines whether the value from the--- previous compilation is still good.  This abstracts out the--- strategy for determining when a cached result is no longer valid.------ If an exception is raised during the processing of the action, it--- will be thrown to all waiting threads, and for all requests made--- before the recompile condition is reached.-protectedHintEvaluator :: forall a.-                          IO a-                       -> (a -> IO Bool)-                       -> IO HintLoadable-                       -> IO (Snap (), IO ())-protectedHintEvaluator start test getInternals = do-    -- The list of requesters waiting for a result.  Contains the-    -- ThreadId in case of exceptions, and an empty MVar awaiting a-    -- successful result.-    readerContainer <- newReaderContainer--    -- Contains the previous result and initialization value, and the-    -- time it was stored, if a previous result has been computed.-    -- The result stored is either the actual result and-    -- initialization result, or the exception thrown by the-    -- calculation.-    resultContainer <- newResultContainer--    -- The model used for the above MVars in the returned action is-    -- "keep them full, unless updating them."  In every case, when-    -- one of those MVars is emptied, the next action is to fill that-    -- same MVar.  This makes deadlocking on MVar wait impossible.-    let snap = do-            let waitForNewResult :: IO (Snap ())-                waitForNewResult = do-                    -- Need to calculate a new result-                    tid <- myThreadId-                    reader <- newEmptyMVar--                    readers <- takeMVar readerContainer--                    -- Some strictness is employed to ensure the MVar-                    -- isn't holding on to a chain of unevaluated thunks.-                    let pair = (tid, reader)-                        newReaders = readers `seq` pair `seq` (pair : readers)-                    putMVar readerContainer $! newReaders--                    -- If this is the first reader to queue, clean up the-                    -- previous state, if there was any, and then begin-                    -- evaluation of the new code and state.-                    when (null readers) $ do-                        let runAndFill = block $ do-                                -- run the cleanup action-                                previous <- readMVar resultContainer-                                unblock $ cleanup previous--                                -- compile the new internals and initialize-                                stateInitializer <- unblock getInternals-                                res <- unblock stateInitializer--                                let a = fst res--                                clearAndNotify (Right res)-                                               (flip putMVar a . snd)--                            killWaiting :: SomeException -> IO ()-                            killWaiting e = block $ do-                                clearAndNotify (Left e) (flip throwTo e . fst)-                                throwIO e--                            clearAndNotify r f = do-                                a <- unblock start-                                _ <- swapMVar resultContainer $ Just (r, a)-                                allReaders <- swapMVar readerContainer []-                                mapM_ f allReaders--                        _ <- forkIO $ runAndFill `catch` killWaiting-                        return ()--                    -- Wait for the evaluation of the action to complete,-                    -- and return its result.-                    takeMVar reader--            existingResult <- liftIO $ readMVar resultContainer--            getResult <- liftIO $ case existingResult of-                Just (res, a) -> do-                    -- There's an existing result.  Check for validity-                    valid <- test a-                    case (valid, res) of-                        (True, Right (x, _)) -> return x-                        (True, Left e)       -> throwIO e-                        (False, _)           -> waitForNewResult-                Nothing -> waitForNewResult-            getResult--        clean = do-             let msg = "invalid dynamic loader state.  " ++-                       "The cleanup action has been executed"-             contents <- swapMVar resultContainer $ error msg-             cleanup contents--    return (snap, clean)-  where-    newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))])-    newReaderContainer = newMVar []--    newResultContainer :: IO (MVar (Maybe (Either SomeException-                                                  (Snap (), IO ()), a)))-    newResultContainer = newMVar Nothing--    cleanup (Just (Right (_, clean), _)) = clean-    cleanup _                            = return ()
− src/Snap/Loader/Devel/Signal.hs 
@@ -1,43 +0,0 @@-{-# LANGUAGE CPP #-}-module Snap.Loader.Devel.Signal (protectHandlers) where--import Control.Exception (bracket)--#ifdef mingw32_HOST_OS-import GHC.ConsoleHandler as C---saveHandlers :: IO C.Handler-saveHandlers = C.installHandler Ignore---restoreHandlers :: C.Handler -> IO C.Handler-restoreHandlers = C.installHandler---#else-import qualified System.Posix.Signals as S--helper :: S.Handler -> S.Signal -> IO S.Handler-helper handler signal = S.installHandler signal handler Nothing---signals :: [S.Signal]-signals = [ S.sigQUIT-          , S.sigINT-          , S.sigHUP-          , S.sigTERM-          ]---saveHandlers :: IO [S.Handler]-saveHandlers = mapM (helper S.Ignore) signals---restoreHandlers :: [S.Handler] -> IO [S.Handler]-restoreHandlers h = sequence $ zipWith helper h signals---#endif-protectHandlers :: IO a -> IO a-protectHandlers a = bracket saveHandlers restoreHandlers $ const a
− src/Snap/Loader/Devel/TreeWatcher.hs 
@@ -1,41 +0,0 @@-module Snap.Loader.Devel.TreeWatcher-    ( TreeStatus-    , getTreeStatus-    , checkTreeStatus-    ) where--import Control.Applicative--import System.Directory-import System.Directory.Tree--import System.Time------------------------------------------------------------------------------------ | An opaque representation of the contents and last modification--- times of a forest of directory trees.-data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime]------------------------------------------------------------------------------------ | Create a 'TreeStatus' for later checking with 'checkTreeStatus'-getTreeStatus :: [FilePath] -> IO TreeStatus-getTreeStatus = liftA2 (<$>) TS readModificationTimes------------------------------------------------------------------------------------ | Checks that all the files present in the initial set of paths are--- the exact set of files currently present, with unchanged modifcations times-checkTreeStatus :: TreeStatus -> IO Bool-checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths-  where-    check = and . zipWith (==) entries------------------------------------------------------------------------------------ | This is the core of the functions in this module.  It converts a--- list of filepaths into a list of 'AnchoredDirTree' annotated with--- the modification times of the files located in those paths.-readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime]-readModificationTimes = mapM $ readDirectoryWith getModificationTime
− src/Snap/Loader/Prod.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Snap.Loader.Prod-  ( loadSnapTH-  ) where--import           Language.Haskell.TH------------------------------------------------------------------------------------ | This function provides a non-magical type-compatible loader for--- the one in Snap.Loader.Devel, allowing switching one import to--- provide production-mode compilation.------ This could be considered a TH wrapper around a function------ > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ()))--- >                        -> [String] -> IO (a, Snap (), IO ())------ The third argument is unused, and only present for--- type-compatibility with Snap.Loader.Devel-loadSnapTH :: Q Exp -> Name -> [String] -> Q Exp-loadSnapTH initializer action _additionalWatchDirs =-    [| do value <- $initializer-          (site, conf) <- $(varE action) value-          return (value, site, conf) |]
src/Snap/Snaplet.hs view
@@ -46,15 +46,15 @@     Snaplet   , SnapletConfig +  -- * Lenses+  -- $lenses+   -- * Snaplet Helper Functions   -- $snapletHelpers   , snapletConfig   , snapletValue   , subSnaplet -  -- * Lenses-  -- $lenses-   -- * MonadSnaplet   -- $monadSnaplet   , MonadSnaplet(..)@@ -64,6 +64,7 @@   , getSnapletDescription   , getSnapletUserConfig   , getSnapletRootURL+  , snapletURL   , getRoutePattern   , setRoutePattern @@ -91,20 +92,30 @@   , addPostInitHook   , addPostInitHookBase   , printInfo+  , getRoutes+  , getEnvironment    -- * Routes   -- $routes   , addRoutes-  , wrapHandlers+  , wrapSite    -- * Handlers   , Handler+  , failIfNotLocal   , reloadSite+  , modifyMaster+  , bracketHandler    -- * Serving Applications   , runSnaplet   , combineConfig   , serveSnaplet+  , serveSnapletNoArgParsing+  , loadAppConfig++  -- * Snaplet Lenses+  , SnapletLens   ) where  @@ -134,7 +145,7 @@ -- contains all of the application state; we call this state the \"base\" -- state. ----- We provide a couple of helper functions for working with Snaplet types.+-- 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@@ -143,53 +154,52 @@ -- /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 the @data-lens@ library--- (<http://hackage.haskell.org/package/data-lens>). A lens, notated as--- follows:+-- Our solution is to use /lenses/, as defined in Edward Kmett's @lens@+-- library (<http://hackage.haskell.org/package/lens>). A lens, notated+-- as follows: ----- > Lens a b+-- > SimpleLens a b ----- is a \"getter\" and a \"setter\" rolled up into one. The @data-lens@--- library provides the following functions:+-- is conceptually a \"getter\" and a \"setter\" rolled up into one. The+-- @lens@ library provides the following functions: ----- > getL :: (Lens a b) -> a -> b--- > setL :: (Lens a b) -> b -> a -> a--- > modL :: (Lens a b) -> (b -> b) -> a -> a+-- > 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 of type @a@. The @data-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:+-- 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]+-- > makeLenses ''App -- -- would define lenses: ----- > foo                :: Lens App (Snaplet Foo)--- > bar                :: Lens App (Snaplet Bar)--- > someNonSnapletData :: Lens App String+-- > foo                :: SimpleLens App (Snaplet Foo)+-- > bar                :: SimpleLens App (Snaplet Bar)+-- > someNonSnapletData :: SimpleLens App String ----- The coolest thing about @data-lens@ lenses is that they /compose/, using--- the "Control.Category"'s generalization of the @(.)@ operator. If the @Foo@--- type had a field of type @Quux@ within it with a lens @quux :: Lens Foo--- Quux@, then you could create a lens of type @Lens App Quux@ by composition:+-- 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.Category--- > import Prelude hiding ((.))    -- you have to hide (.) from the Prelude--- >                                -- to use Control.Category.(.)+-- > import Control.Lens -- > -- > data Foo = Foo { _quux :: Quux }--- > makeLenses [''Foo]+-- > makeLenses ''Foo -- > -- > -- snapletValue is defined in the framework:--- > snapletValue :: Lens (Snaplet a) a+-- > snapletValue :: SimpleLens (Snaplet a) a -- >--- > appQuuxLens :: Lens App Quux--- > appQuuxLens = quux . snapletValue . foo+-- > appQuuxLens :: SimpleLens App Quux+-- > appQuuxLens = foo . snapletValue . quux ----- Lens composition is very similar to function composition, but it gives you--- a composed getter and setter at the same time.+-- 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@@ -199,7 +209,7 @@ -- 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 @Lens App (Snaplet 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@@ -248,7 +258,7 @@ -- $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--- 'wrapHandlers'.+-- 'wrapSite'.   {-@@ -280,6 +290,7 @@ 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 >@@ -290,7 +301,7 @@ >     , _companyName :: String >     } >-> makeLenses [''App]+> makeLenses ''App  The next thing we need to do is define an initializer. @@ -301,7 +312,7 @@ >     bs <- nestSnaplet "" $ nameSnaplet "baz" $ barInit heist >     addRoutes [ ("/hello", writeText "hello world") >               ]->     wrapHandlers (<|> with heist heistServe)+>     wrapSite (<|> with heist heistServe) >     return $ App hs fs bs "fooCorp"  Then we define a simple main to run the application.
src/Snap/Snaplet/Auth.hs view
@@ -1,22 +1,21 @@ {-# 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.+{-# 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@@ -44,29 +43,38 @@   , UserId(..)   , Password(..)   , AuthFailure(..)-  , BackendError(..)   , 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
src/Snap/Snaplet/Auth/AuthManager.hs view
@@ -1,52 +1,47 @@--{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveDataTypeable #-}+------------------------------------------------------------------------------+-- | Internal module exporting AuthManager implementation.+--+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE ExistentialQuantification  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}  module Snap.Snaplet.Auth.AuthManager--(-  -- * AuthManager Datatype+  ( -- * AuthManager Datatype     AuthManager(..) -  -- * Backend Typeclass-  , IAuthBackend(..)--  -- * Context-free Operations-  , buildAuthUser--) where+    -- * Backend Typeclass+    , IAuthBackend(..) +    -- * Context-free Operations+    , buildAuthUser+  ) where +------------------------------------------------------------------------------ import           Data.ByteString (ByteString)-import           Data.Lens.Lazy-import           Data.Time import           Data.Text (Text)+import           Data.Time import           Web.ClientSession  import           Snap.Snaplet import           Snap.Snaplet.Session import           Snap.Snaplet.Auth.Types + --------------------------------------------------------------------------------- | Create a new user from just a username and password+-- | Creates a new user from a username and password. ----- May throw a "DuplicateLogin" if given username is not unique-buildAuthUser-  :: (IAuthBackend r)-  => r-  -- ^ An auth backend-  -> Text-  -- ^ Username-  -> ByteString-  -- ^ Password-  -> IO AuthUser+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+              userLogin     = unm+            , userPassword  = Nothing             , userCreatedAt = Just now             , userUpdatedAt = Just now             }@@ -57,46 +52,56 @@ ------------------------------------------------------------------------------ -- | All storage backends need to implement this typeclass ----- Backend operations may throw 'BackendError's class IAuthBackend r where--  -- | Needs to create or update the given 'AuthUser' record-  save :: r -> AuthUser -> IO AuthUser--  lookupByUserId :: r -> UserId -> IO (Maybe AuthUser)--  lookupByLogin :: r -> Text -> IO (Maybe AuthUser)--  lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser)--  destroy :: r -> AuthUser -> IO ()+  -- | 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+      backend               :: r+        -- ^ Storage back-end -  , session :: Lens b (Snaplet SessionManager)-  -- ^ A lens pointer to a SessionManager+    , session               :: SnapletLens b SessionManager+        -- ^ A lens pointer to a SessionManager -  , activeUser :: Maybe AuthUser-  -- ^ A per-request logged-in user cache+    , activeUser            :: Maybe AuthUser+        -- ^ A per-request logged-in user cache -  , minPasswdLen :: Int-  -- ^ Password length range+    , minPasswdLen          :: Int+        -- ^ Password length range -  , rememberCookieName :: ByteString-  -- ^ Cookie name for the remember token+    , rememberCookieName    :: ByteString+        -- ^ Cookie name for the remember token -  , rememberPeriod :: Maybe Int-  -- ^ Remember period in seconds. Defaults to 2 weeks.+    , rememberCookieDomain  :: Maybe ByteString+        -- ^ Domain for which remember cookie will be created. -  , siteKey :: Key-  -- ^ A unique encryption key used to encrypt remember cookie+    , rememberPeriod        :: Maybe Int+        -- ^ Remember period in seconds. Defaults to 2 weeks. -  , lockout :: Maybe (Int, NominalDiffTime)-  -- ^ Lockout after x tries, re-allow entry after y seconds-  }+    , 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
src/Snap/Snaplet/Auth/Backends/JsonFile.hs view
@@ -1,33 +1,38 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeOperators        #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-} - module Snap.Snaplet.Auth.Backends.JsonFile   ( initJsonFileAuthManager   , mkJsonAuthMgr   ) where  -import           Control.Applicative-import           Control.Monad.CatchIO (throw)+import           Control.Applicative ((<|>))+import           Control.Monad (join) import           Control.Monad.State import           Control.Concurrent.STM import           Data.Aeson-import qualified Data.Attoparsec as Atto+import           Data.Aeson.Parser (json)+import qualified Data.Attoparsec.ByteString as Atto import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString as B import qualified Data.Map as HM import           Data.Map (Map)-import           Data.Maybe (fromJust, isJust)+import           Data.Maybe (fromJust, isJust, listToMaybe)+import           Data.Monoid (mempty) import           Data.Text (Text) import qualified Data.Text as T-import           Data.Lens.Lazy 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@@ -37,30 +42,34 @@  ------------------------------------------------------------------------------ -- | Initialize a JSON file backed 'AuthManager'-initJsonFileAuthManager-  :: AuthSettings-  -- ^ Authentication settings for your app-  -> Lens b (Snaplet 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 =-  makeSnaplet "JsonFileAuthManager"-      "A snaplet providing user authentication using a JSON-file backend"-      Nothing $ liftIO $ do-    key <- getKey (asSiteKey s)-    jsonMgr <- mkJsonAuthMgr db-    return $ AuthManager {-        backend = jsonMgr-      , session = l-      , activeUser = Nothing-      , minPasswdLen = asMinPasswdLen s-      , rememberCookieName = asRememberCookieName s-      , rememberPeriod = asRememberPeriod s-      , siteKey = key-      , lockout = asLockout s-    }+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+                       }   ------------------------------------------------------------------------------@@ -71,51 +80,65 @@ mkJsonAuthMgr fp = do   db <- loadUserCache fp   let db' = case db of-              Left e -> error e+              Left e  -> error e               Right x -> x   cache <- newTVarIO db'-  return $ JsonFileAuthManager {++  return $! JsonFileAuthManager {       memcache = cache-    , dbfile = fp+    , 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+------------------------------------------------------------------------------+-- | JSON user back-end stores the user data and indexes for login and token -- based logins. data UserCache = UserCache {-    uidCache    :: UserIdCache          -- the actual datastore-  , loginCache  :: LoginUserCache       -- fast lookup for login field-  , tokenCache  :: RemTokenUserCache    -- fast lookup for remember tokens-  , uidCounter  :: Int                  -- user id counter+    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+    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@@ -123,213 +146,215 @@     True -> do       d <- B.readFile fp       case Atto.parseOnly json d of-        Left e -> return . Left $ "Can't open JSON auth backend. Error: " ++ e+        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+          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+  , dbfile   :: FilePath }  -instance IAuthBackend JsonFileAuthManager where--  save mgr u = do-    now <- getCurrentTime+------------------------------------------------------------------------------+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+    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+      res   <- case userId u of+                 Nothing -> create cache now oldByLogin+                 Just _  -> update cache now oldById       case res of-        Left e -> return $ Left e+        Left e             -> return $! Left e         Right (cache', u') -> do           writeTVar (memcache mgr) cache'-          return $ Right (cache', u')+          return $! Right $! (cache', u')+     case res of-      Left e -> throw e+      Left _             -> return $! Left BackendError       Right (cache', u') -> do         dumpToDisk cache'-        return u'-    where-      create-        :: UserCache-        -> UTCTime-        -> (Maybe AuthUser)-        -> STM (Either BackendError (UserCache, AuthUser))-      create cache now old = do-        case old of-          Just _ -> return $ Left DuplicateLogin-          Nothing -> do-            new <- do-              let uid' = UserId . showT $ uidCounter cache + 1-              let u' = u { userUpdatedAt = Just now, userId = Just uid' }-              return $ cache {-                uidCache = HM.insert uid' u' $ uidCache cache-              , loginCache = HM.insert (userLogin u') uid' $ loginCache cache-              , tokenCache = case userRememberToken u' of-                                Nothing -> tokenCache cache-                                Just x -> HM.insert x uid' $ tokenCache cache-              , uidCounter = uidCounter cache + 1-              }-            return $ Right (new, getLastUser new)+        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 BackendError (UserCache, AuthUser))-      update cache now old =-        case old of-          Nothing -> return $ Left $-                       BackendError "User not found; should never happen"-          Just x -> do-            let oldLogin = userLogin x-            let oldToken = userRememberToken x-            let uid = fromJust $ userId u-            let newLogin = userLogin u-            let newToken = userRememberToken u-            let lc = if oldLogin /= userLogin u-                      then HM.insert newLogin uid . HM.delete oldLogin $-                               loginCache cache-                      else loginCache cache-            let tc = if oldToken /= newToken && isJust oldToken-                      then HM.delete (fromJust oldToken) $ loginCache cache-                      else tokenCache cache-            let tc' = case newToken of-                        Just t -> HM.insert t uid tc-                        Nothing -> tc-            let u' = u { userUpdatedAt = Just now }-            let new = cache {-                          uidCache = HM.insert uid u' $ uidCache cache-                        , loginCache = lc-                        , tokenCache = tc'-                      }-            return $ Right (new, u')+    --------------------------------------------------------------------------+    -- 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 -      -- 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)+          let lc       = if oldLogin /= userLogin u+                           then HM.insert newLogin uid $+                                HM.delete oldLogin $+                                loginCache cache+                           else loginCache cache -      -- Get's 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."+          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+    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)+        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+  return $! f cache  +------------------------------------------------------------------------------ getUser :: UserCache -> UserId -> Maybe AuthUser getUser cache uid = HM.lookup uid (uidCache cache)   --------------------------------------------------------------------------------- JSON Instances----------------------------------------------------------------------------------+showT :: Int -> Text+showT = T.pack . show  +                             --------------------+                             -- JSON Instances --+                             --------------------++------------------------------------------------------------------------------ instance ToJSON UserCache where   toJSON uc = object-    [ "uidCache"   .= uidCache uc+    [ "uidCache"   .= uidCache   uc     , "loginCache" .= loginCache uc+    , "emailCache" .= emailCache uc     , "tokenCache" .= tokenCache uc-    , "uidCounter" .= uidCounter 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"--instance ToJSON AuthUser where-  toJSON u = object-    [ "uid" .= userId u-    , "login" .= userLogin 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" .= userCurrentLoginIp u-    , "last_ip" .= userLastLoginIp u-    , "created_at" .= userCreatedAt u-    , "updated_at" .= userUpdatedAt u-    , "meta" .= userMeta u ]---instance FromJSON AuthUser where-  parseJSON (Object v) = AuthUser-    <$> v .: "uid"-    <*> v .: "login"-    <*> 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"-    <*> v .: "current_ip"-    <*> v .: "last_ip"-    <*> v .: "created_at"-    <*> v .: "updated_at"-    <*> return []-    <*> v .: "meta"-  parseJSON _ = error "Unexpected JSON input"---instance ToJSON Password where-  toJSON (Encrypted x) = toJSON x-  toJSON (ClearText _) =-      error "ClearText passwords can't be serialized into JSON"---instance FromJSON Password where-  parseJSON = fmap Encrypted . parseJSON---showT :: Int -> Text-showT = T.pack . show
src/Snap/Snaplet/Auth/Handlers.hs view
@@ -1,213 +1,251 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types #-}--{-|--  Pre-packaged Handlers that deal with form submissions and standard use-cases-  involving authentication.+{-# 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.CatchIO (throw)+import           Control.Monad (join, liftM, liftM2) import           Control.Monad.State+import           Control.Monad.Trans.Maybe import           Data.ByteString (ByteString)-import           Data.Lens.Lazy-import           Data.Maybe (isJust)+import           Data.Maybe import           Data.Serialize hiding (get) import           Data.Time import           Data.Text.Encoding (decodeUtf8)-import           Data.Text (Text)+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-import           Snap.Snaplet.Session.Common-import           Snap.Snaplet.Session.SecureCookie--- --------------------------------------------------------------------------------- Higher level functions-------------------------------------------------------------------------------  +                         ----------------------------+                         -- Higher level functions --+                         ----------------------------+ ------------------------------------------------------------------------------ -- | Create a new user from just a username and password ----- May throw a "DuplicateLogin" if given username is not unique-createUser-  :: Text -- Username-  -> ByteString -- Password-  -> Handler b (AuthManager b) AuthUser-createUser unm pwd = withBackend (\r -> liftIO $ buildAuthUser r unm pwd)+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+--+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-  :: ByteString       -- ^ Username/login for user-  -> Password         -- ^ Should be ClearText-  -> Bool             -- ^ Set remember token?-  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)-loginByUsername _ (Encrypted _) _ =-  error "Cannot login with encrypted password"-loginByUsername unm pwd rm = do-  sk <- gets siteKey-  cn <- gets rememberCookieName-  rp <- gets rememberPeriod-  withBackend $ loginByUsername' sk cn rp+--+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 Int -> t-                     -> Handler b (AuthManager b)-                                (Either AuthFailure AuthUser)-    loginByUsername' sk cn rp r = do-      au <- liftIO $ lookupByLogin r (decodeUtf8 unm)-      case au of-        Nothing  -> return $ Left UserNotFound-        Just au' -> do-          res <- checkPasswordAndLogin au' pwd-          case res of-            Left e -> return $ Left e-            Right au'' -> do-              case rm of-                True -> do-                  token <- liftIO $ randomToken 64-                  setRememberToken sk cn rp token-                  let au''' = au''-                          { userRememberToken = Just (decodeUtf8 token) }-                  saveUser au'''-                  return $ Right au'''-                False -> return $ Right au''+    --------------------------------------------------------------------------+    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) (Maybe AuthUser)-loginByRememberToken = withBackend $ \r -> do-  sk <- gets siteKey-  rc <- gets rememberCookieName-  rp <- gets rememberPeriod-  token <- getRememberToken sk rc rp-  au <- maybe (return Nothing)-              (liftIO . lookupByRememberToken r . decodeUtf8) token-  case au of-    Just au' -> forceLogin au' >> return au-    Nothing -> return Nothing+--+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-  forgetRememberToken rc-  modify (\mgr -> mgr { activeUser = Nothing } )+    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 -> loginByRememberToken-    Just uid' -> liftIO $ lookupByUserId r uid'+    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 `fmap` currentUser+isLoggedIn = isJust <$> currentUser   ------------------------------------------------------------------------------ -- | Create or update a given user ----- May throw a 'BackendError' if something goes wrong.-saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser-saveUser u = withBackend $ liftIO . flip save u+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 ----- May throw a 'BackendError' if something goes wrong. destroyUser :: AuthUser -> Handler b (AuthManager b) () destroyUser u = withBackend $ liftIO . flip destroy u  ----------------------------------------------------------------------------------  Lower level helper functions-----------------------------------------------------------------------------------+                      -----------------------------------+                      --  Lower level helper functions --+                      -----------------------------------  ------------------------------------------------------------------------------ -- | Mutate an 'AuthUser', marking failed authentication -- -- This will save the user to the backend.-markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser+--+markAuthFail :: AuthUser+             -> Handler b (AuthManager b) (Either AuthFailure AuthUser) markAuthFail u = withBackend $ \r -> do-  lo <- gets lockout-  incFailCtr u >>= checkLockout lo >>= liftIO . save r+    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'+    --------------------------------------------------------------------------+    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) AuthUser-markAuthSuccess u = withBackend $ \r -> do-  incLoginCtr u >>= updateIp >>= updateLoginTS-    >>= resetFailCtr >>= liftIO . save r+--+markAuthSuccess :: AuthUser+                -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+markAuthSuccess u = withBackend $ \r ->+                        incLoginCtr u     >>=+                        updateIp          >>=+                        updateLoginTS     >>=+                        resetFailCtr      >>=+                        liftIO . save r   where+    --------------------------------------------------------------------------     incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }++    --------------------------------------------------------------------------     updateIp u' = do-      ip <- rqRemoteAddr `fmap` getRequest-      return $ u' { userLastLoginIp = userCurrentLoginIp u'-                  , userCurrentLoginIp = Just ip }+        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 }+        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. --@@ -221,29 +259,32 @@ -- 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+    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 })-          user' <- markAuthSuccess user-          return $ Right user'+          markAuthSuccess user   ------------------------------------------------------------------------------@@ -251,27 +292,27 @@ -- -- 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 AuthUser)+--+forceLogin :: AuthUser       -- ^ An existing user, somehow looked up from db+           -> Handler b (AuthManager b) (Either AuthFailure ()) forceLogin u = do-  s <- gets session-  withSession s $ do-    case userId u of-      Just x -> do-        withTop s (setSessionUserId x)-        return $ Right u-      Nothing -> return . Left $-        AuthError "forceLogin: Can't force the login of a user without userId"+    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----------------------------------------------------------------------------------+                     ------------------------------------+                     -- Internal, non-exported helpers --+                     ------------------------------------  +------------------------------------------------------------------------------ getRememberToken :: (Serialize t, MonadSnap m)                  => Key                  -> ByteString@@ -280,21 +321,20 @@ getRememberToken sk rc rp = getSecureCookie rc sk rp  +------------------------------------------------------------------------------ setRememberToken :: (Serialize t, MonadSnap m)                  => Key                  -> ByteString+                 -> Maybe ByteString                  -> Maybe Int                  -> t                  -> m ()-setRememberToken sk rc rp token = setSecureCookie rc sk rp token---forgetRememberToken :: MonadSnap m => ByteString -> m ()-forgetRememberToken rc = expireCookie rc (Just "/")+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 @@ -307,10 +347,11 @@  ------------------------------------------------------------------------------ -- | Get the current user's 'UserId' from the active session+-- getSessionUserId :: Handler b SessionManager (Maybe UserId) getSessionUserId = do   uid <- getFromSession "__user_id"-  return $ uid >>= return . UserId+  return $ liftM UserId uid   ------------------------------------------------------------------------------@@ -318,86 +359,109 @@ -- -- 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 :: 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+    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+      -- ^ 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'+    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) AuthUser+  :: ByteString            -- ^ Login field+  -> ByteString            -- ^ Password field+  -> Handler b (AuthManager b) (Either AuthFailure AuthUser) registerUser lf pf = do-  l <- fmap decodeUtf8 `fmap` getParam lf-  p <- getParam pf-  case liftM2 (,) l p of-    Nothing -> throw PasswordMissing-    Just (lgn, pwd) -> do-      createUser lgn pwd+    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+      -- ^ Username field   -> ByteString-  -- ^ Password field+      -- ^ Password field   -> Maybe ByteString-  -- ^ Remember field; Nothing if you want no remember function.+      -- ^ Remember field; Nothing if you want no remember function.   -> (AuthFailure -> Handler b (AuthManager b) ())-  -- ^ Upon failure+      -- ^ Upon failure   -> Handler b (AuthManager b) ()-  -- ^ Upon success+      -- ^ Upon success   -> Handler b (AuthManager b) ()-loginUser unf pwdf remf loginFail loginSucc = do-    username <- getParam unf-    password <- getParam pwdf-    remember <- maybe False (=="1") `fmap`-                maybe (return Nothing) getParam remf-    mMatch <- case password of-      Nothing -> return $ Left PasswordMissing-      Just password' -> do-        case username of-          Nothing -> return . Left $ AuthError "Username is missing"-          Just username' -> do-            loginByUsername username' (ClearText password') remember-    either loginFail (const loginSucc) mMatch+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 :: Handler b (AuthManager b) ()   -- ^ What to do after logging out+           -> Handler b (AuthManager b) () logoutUser target = logout >> target  @@ -407,17 +471,17 @@ -- -- This function has no DB cost - only checks to see if a user_id is present -- in the current session.-requireUser-  :: Lens b (Snaplet (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 :: 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+    loggedIn <- withTop auth isLoggedIn+    if loggedIn then good else bad   ------------------------------------------------------------------------------@@ -428,10 +492,55 @@ -- (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.+--+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 bckend _ _ _ _ _ _ _) <- get-  return $ f bckend+  (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+++
src/Snap/Snaplet/Auth/SpliceHelpers.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP                       #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}  {-| @@ -11,65 +13,190 @@ -}  module Snap.Snaplet.Auth.SpliceHelpers-  (-    addAuthSplices+  ( addAuthSplices+  , compiledAuthSplices+  , userCSplices+  , userISplices   , ifLoggedIn   , ifLoggedOut+  , loggedInUser+  , cIfLoggedIn+  , cIfLoggedOut+  , cLoggedInUser   ) where -import           Data.Lens.Lazy+------------------------------------------------------------------------------+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           Text.Templating.Heist-+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: -- \<ifLoggedIn\> -- \<ifLoggedOut\>+-- \<loggedInUser\> addAuthSplices   :: HasHeist b-  => Lens b (Snaplet (AuthManager b))-  -- ^ A lens reference to 'AuthManager'+  => Snaplet (Heist b)+  -> SnapletLens b (AuthManager b)+      -- ^ A lens reference to 'AuthManager'   -> Initializer b v ()-addAuthSplices auth = addSplices-  [ ("ifLoggedIn", ifLoggedIn auth)-  , ("ifLoggedOut", ifLoggedOut auth)-  ]+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. -- -- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>-ifLoggedIn-  :: Lens b (Snaplet (AuthManager b))-  -> SnapletSplice b v+ifLoggedIn :: SnapletLens b (AuthManager b) -> SnapletISplice b ifLoggedIn auth = do-  chk <- liftHandler $ withTop auth isLoggedIn-  case chk of-    True -> liftHeist $ getParamNode >>= return . X.childNodes-    False -> return []+    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.+--+-- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>+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. -- -- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>-ifLoggedOut-  :: Lens b (Snaplet (AuthManager b))-  -> SnapletSplice b v+ifLoggedOut :: SnapletLens b (AuthManager b) -> SnapletISplice b ifLoggedOut auth = do-  chk <- liftHandler $ withTop auth isLoggedIn-  case chk of-    False -> liftHeist $ getParamNode >>= return . X.childNodes-    True -> return []+    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.+--+-- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>+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
src/Snap/Snaplet/Auth/Types.hs view
@@ -1,42 +1,77 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE ExistentialQuantification  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE StandaloneDeriving         #-}  module Snap.Snaplet.Auth.Types where -import           Control.Monad.CatchIO+------------------------------------------------------------------------------+import           Control.Arrow+import           Control.Monad.Trans+import           Crypto.PasswordStore import           Data.Aeson-import           Data.ByteString (ByteString)-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM-import           Data.Hashable (Hashable)+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           Data.Text (Text)-import           Crypto.PasswordStore+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)+  deriving (Read, Show, Ord, Eq)   --------------------------------------------------------------------------------- Turn a 'ClearText' password into an 'Encrypted' password, ready to be--- stuffed into a database.+-- | 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) = do-  hashed <- makePassword p 12-  return $ Encrypted hashed+encryptPassword (ClearText p)    = Encrypted `fmap` encrypt p   +------------------------------------------------------------------------------ checkPassword :: Password -> Password -> Bool-checkPassword (ClearText pw) (Encrypted pw') = verifyPassword pw pw'+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" @@ -46,17 +81,28 @@ -- 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 =-    UserNotFound-  | IncorrectPassword-  | PasswordMissing-  | LockedOut UTCTime-  -- ^ Locked out until given time-  | AuthError String-  deriving (Read, Show, Ord, Eq, Typeable)+data AuthFailure = AuthError String+                 | BackendError+                 | DuplicateLogin+                 | EncryptedPassword+                 | IncorrectPassword+                 | LockedOut UTCTime    -- ^ Locked out until given time+                 | PasswordMissing+                 | UsernameMissing+                 | UserNotFound+  deriving (Read, Ord, Eq, Typeable)  -instance Exception AuthFailure+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."   ------------------------------------------------------------------------------@@ -66,59 +112,74 @@ -- 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)+  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)+  deriving (Read, Show, Ord, Eq)   ------------------------------------------------------------------------------ -- | Type representing the concept of a User in your application. data AuthUser = AuthUser-  { userId :: Maybe UserId-  , userLogin :: 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-  , userRoles :: [Role]-  , userMeta :: HashMap Text Value-  } deriving (Show,Eq)+    { 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 = ""-  , 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-  , userRoles = []-  , userMeta = HM.empty-}+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+    }   ------------------------------------------------------------------------------@@ -126,24 +187,28 @@ -- clear-text; it will be encrypted into a 'Encrypted'. setPassword :: AuthUser -> ByteString -> IO AuthUser setPassword au pass = do-  pw <- Encrypted `fmap` (makePassword pass 12)-  return $ au { userPassword = Just pw }+    pw <- Encrypted <$> makePassword pass defaultStrength+    return $! au { userPassword = Just pw }   --------------------------------------------------------------------------------- | Authetication settings defined at initialization time+-- | Authentication settings defined at initialization time data AuthSettings = AuthSettings {-    asMinPasswdLen :: Int-  -- ^ Currently not used/checked+    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+      -- ^ 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 }  @@ -157,19 +222,116 @@ -- > asSiteKey = "site_key.txt" defAuthSettings :: AuthSettings defAuthSettings = AuthSettings {-    asMinPasswdLen = 8+    asMinPasswdLen       = 8   , asRememberCookieName = "_remember"-  , asRememberPeriod = Just (2*7*24*60*60)-  , asLockout = Nothing-  , asSiteKey = "site_key.txt"+  , asRememberPeriod     = Just (2*7*24*60*60)+  , asLockout            = Nothing+  , asSiteKey            = "site_key.txt" }  -data BackendError =-    DuplicateLogin-  | BackendError String-  deriving (Eq,Show,Read,Typeable)+------------------------------------------------------------------------------+-- | 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  -instance Exception BackendError+                             --------------------+                             -- 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
+ src/Snap/Snaplet/Config.hs view
@@ -0,0 +1,97 @@+{-# 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
src/Snap/Snaplet/Heist.hs view
@@ -1,9 +1,7 @@-{-|--The Heist snaplet makes it easy to add Heist to your application and use it in-other snaplets.---}+------------------------------------------------------------------------------+-- | The Heist snaplet makes it easy to add Heist to your application and use+-- it in other snaplets.+--  module Snap.Snaplet.Heist   (@@ -15,14 +13,29 @@   -- $initializerSection   , heistInit   , heistInit'+  , Unclassed.heistReloader+  , Unclassed.setInterpreted+  , Unclassed.getCurHeistConfig    , addTemplates   , addTemplatesAt-  , modifyHeistTS-  , withHeistTS-  , addSplices+  , Unclassed.addConfig+  , getHeistState+  , modifyHeistState+  , withHeistState    -- * Handler Functions   -- $handlerSection+  , gRender+  , gRenderAs+  , gHeistServe+  , gHeistServeSingle+  , chooseMode++  , cRender+  , cRenderAs+  , cHeistServe+  , cHeistServeSingle+   , render   , renderAs   , heistServe@@ -34,27 +47,25 @@   -- * Writing Splices   -- $spliceSection   , Unclassed.SnapletHeist-  , Unclassed.SnapletSplice-  , Unclassed.liftHeist-  , Unclassed.liftHandler-  , Unclassed.liftAppHandler-  , Unclassed.liftWith-  , Unclassed.bindSnapletSplices+  , Unclassed.SnapletCSplice+  , Unclassed.SnapletISplice    , clearHeistCache   ) where +------------------------------------------------------------------------------ import           Prelude hiding (id, (.))+import           Control.Monad.State import           Data.ByteString (ByteString)-import           Data.Lens.Lazy-import           Data.Text (Text)-import           Text.Templating.Heist-+import           Heist+------------------------------------------------------------------------------ import           Snap.Snaplet-+import           Snap.Snaplet.Heist.Internal import qualified Snap.Snaplet.HeistNoClass as Unclassed-import           Snap.Snaplet.HeistNoClass (Heist, heistInit-                                           ,heistInit', clearHeistCache)+import           Snap.Snaplet.HeistNoClass ( heistInit+                                           , heistInit'+                                           , clearHeistCache+                                           )   ------------------------------------------------------------------------------@@ -64,18 +75,18 @@ -- how the heist snaplet might be declared: -- -- > data App = App { _heist :: Snaplet (Heist App) }--- > mkLabels [''App]+-- > makeLenses ''App -- > -- > instance HasHeist App where heistLens = subSnaplet heist -- > -- > appInit = makeSnaplet "app" "" Nothing $ do -- >     h <- nestSnaplet "heist" heist $ heistInit "templates"--- >     addSplices myAppSplices+-- >     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 :: Lens (Snaplet b) (Snaplet (Heist b))+    heistLens :: SnapletLens (Snaplet b) (Heist b)   -- $initializerSection@@ -84,68 +95,169 @@   --------------------------------------------------------------------------------- | Adds templates to the Heist TemplateState.  Other snaplets should use+-- | 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-             => ByteString-             -- ^ Path to templates (also the url prefix for their routes)+             => Snaplet (Heist b)+             -> ByteString+                 -- ^ The url prefix for the template routes              -> Initializer b v ()-addTemplates pfx = withTop' heistLens (Unclassed.addTemplates pfx)+addTemplates h pfx = withTop' heistLens (Unclassed.addTemplates h pfx)   --------------------------------------------------------------------------------- | Adds templates to the Heist TemplateState, and lets you specify where--- they are found in the filesystem.+-- | 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-               => ByteString-               -- ^ URL prefix for template routes+               => Snaplet (Heist b)+               -> ByteString+                   -- ^ URL prefix for template routes                -> FilePath-               -- ^ Path to templates+                   -- ^ Path to templates                -> Initializer b v ()-addTemplatesAt pfx p = withTop' heistLens (Unclassed.addTemplatesAt pfx p)+addTemplatesAt h pfx p =+    withTop' heistLens (Unclassed.addTemplatesAt h pfx p)   --------------------------------------------------------------------------------- | Allows snaplets to add splices.-addSplices :: (HasHeist b)-           => [(Text, Unclassed.SnapletSplice b v)]-           -- ^ Splices to bind-           -> Initializer b v ()-addSplices = Unclassed.addSplices' heistLens+-- | 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 TemplateState modification.--- Without this function you wouldn't be able to bind more complicated splices--- like the cache tag.-modifyHeistTS :: (HasHeist b)-              => (TemplateState (Handler b b) -> TemplateState (Handler b b))-              -- ^ TemplateState modifying function-              -> Initializer b v ()-modifyHeistTS = Unclassed.modifyHeistTS' 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 'TemplateState'.-withHeistTS :: (HasHeist b)-            => (TemplateState (Handler b b) -> a)-            -- ^ TemplateState function to run-            -> Handler b v a-withHeistTS = Unclassed.withHeistTS' 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.+-- 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+           -- ^ Template name        -> Handler b v () render t = withTop' heistLens (Unclassed.render t) @@ -155,26 +267,32 @@ -- is not found, this returns 'empty'. renderAs :: HasHeist b          => ByteString-         -- ^ Content type to render with+             -- ^ Content type to render with          -> ByteString-         -- ^ Template name+             -- ^ Template name          -> Handler b v () renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t)   --------------------------------------------------------------------------------- | Analogous to 'fileServe'. If the template specified in the request path--- is not found, it returns 'empty'.+-- | 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   --------------------------------------------------------------------------------- | Analogous to 'fileServeSingle'. If the given template is not found,--- this throws an error.+-- | 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+                     -- ^ Template name                  -> Handler b v () heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t) @@ -184,49 +302,48 @@ -- a common combination of heistLocal, bindSplices, and render. renderWithSplices :: HasHeist b                   => ByteString-                  -- ^ Template name-                  -> [(Text, Unclassed.SnapletSplice b v)]-                  -- ^ Splices to bind+                      -- ^ 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--- 'TemplateState'.+-- 'HeistState'. withSplices :: HasHeist b-            => [(Text, Unclassed.SnapletSplice b v)]-            -- ^ Splices to bind+            => Splices (Unclassed.SnapletISplice b)+                -- ^ Splices to bind             -> Handler b v a-            -- ^ Handler to run+                -- ^ Handler to run             -> Handler b v a withSplices = Unclassed.withSplices' heistLens   --------------------------------------------------------------------------------- | Runs a handler with a modified 'TemplateState'.  You might want to use+-- | 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-           => (TemplateState (Handler b b) -> TemplateState (Handler b b))-           -- ^ TemplateState modifying function+           => (HeistState (Handler b b) -> HeistState (Handler b b))+               -- ^ HeistState modifying function            -> Handler b v a-            -- ^ Handler to run+               -- ^ Handler to run            -> Handler b v a heistLocal = Unclassed.heistLocal' heistLens   -- $spliceSection--- As can be seen in the type signature of heistLocal, the internal--- TemplateState used by the heist snaplet is parameterized by (Handler b b).--- 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 you obviously would rather--- work with @Handler b v@ so your local snaplet's state is available.  We--- provide the SnapletHeist monad to make this possible.  The general rule is--- that when you're using Snaplets and Heist, use SnapletHeist instead of--- HeistT (previously called TemplateMonad) and use SnapletSplice instead of--- Splice.+-- 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. 
+ src/Snap/Snaplet/Heist/Compiled.hs view
@@ -0,0 +1,98 @@+{-|++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+
+ src/Snap/Snaplet/Heist/Generic.hs view
@@ -0,0 +1,36 @@+{-|++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
+ src/Snap/Snaplet/Heist/Internal.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE TemplateHaskell #-}+module Snap.Snaplet.Heist.Internal where++import           Prelude+import           Control.Lens+import           Control.Monad (liftM)+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
+ src/Snap/Snaplet/Heist/Interpreted.hs view
@@ -0,0 +1,40 @@+{-|++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+
src/Snap/Snaplet/HeistNoClass.hs view
@@ -1,23 +1,49 @@ {-# 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-  , modifyHeistTS-  , modifyHeistTS'-  , withHeistTS-  , withHeistTS'-  , addSplices-  , addSplices'+  , getHeistState+  , modifyHeistState+  , modifyHeistState'+  , withHeistState+  , withHeistState'++  , gRender+  , gRenderAs+  , gHeistServe+  , gHeistServeSingle+  , chooseMode++  , addConfig+  , cRender+  , cRenderAs+  , cHeistServe+  , cHeistServeSingle+   , render   , renderAs   , heistServe@@ -30,55 +56,47 @@   , renderWithSplices'    , SnapletHeist-  , SnapletSplice-  , runSnapletSplice-  , liftHeist-  , liftWith-  , liftHandler-  , liftAppHandler-  , bindSnapletSplices+  , SnapletISplice+  , SnapletCSplice   ) where  import           Prelude hiding ((.), id)-import           Control.Arrow import           Control.Applicative import           Control.Category-import           Control.Monad.CatchIO (MonadCatchIO)+import           Control.Lens import           Control.Monad.Reader import           Control.Monad.State import           Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.UTF8 as U+import           Data.DList (DList)+import qualified Data.HashMap.Strict as Map+import           Data.IORef import           Data.Maybe-import           Data.Monoid-import           Data.Lens.Lazy-import           Data.Text (Text) import qualified Data.Text as T+import           Data.Text.Encoding import           System.FilePath.Posix-import           Text.Templating.Heist-import           Text.Templating.Heist.Splices.Cache+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   --------------------------------------------------------------------------------- | 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 = Heist-    { _heistTS       :: TemplateState (Handler b b)-    , _heistCTS      :: CacheTagState-    }----------------------------------------------------------------------------------changeTS :: (TemplateState (Handler a a) -> TemplateState (Handler a a))-         -> Heist a-         -> Heist a-changeTS f (Heist ts cts) = Heist (f ts) cts+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   ------------------------------------------------------------------------------@@ -89,329 +107,376 @@ clearHeistCache = clearCacheTagState . _heistCTS  ---------------------------------------------------------------------------------- SnapletSplice functions--------------------------------------------------------------------------------+                         -----------------------------+                         -- 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 m) where+instance MonadSnap m => MonadSnap (HeistT n m) where     liftSnap = lift . liftSnap  ---------------------------------------------------------------------------------- | Monad for working with Heist's API from within a snaplet.-newtype SnapletHeist b v a = SnapletHeist-    (ReaderT (Lens (Snaplet b) (Snaplet v)) (HeistT (Handler b b)) a)-  deriving ( Monad-           , Functor-           , Applicative-           , Alternative-           , MonadIO-           , MonadPlus-           , MonadReader (Lens (Snaplet b) (Snaplet v))-           , MonadCatchIO-           , MonadSnap-           )------------------------------------------------------------------------------------ | Type alias for convenience.-type SnapletSplice b v = SnapletHeist b v Template------------------------------------------------------------------------------------ | Runs the SnapletSplice.-runSnapletSplice :: (Lens (Snaplet b) (Snaplet v))-                 -> SnapletHeist b v a-                 -> HeistT (Handler b b) a-runSnapletSplice l (SnapletHeist m) = runReaderT m l---withSS :: (Lens (Snaplet b) (Snaplet v) -> Lens (Snaplet b) (Snaplet v'))-       -> SnapletHeist b v' a-       -> SnapletHeist b v a-withSS f (SnapletHeist m) = SnapletHeist $ withReaderT f m------------------------------------------------------------------------------------ | Lifts a HeistT action into SnapletHeist.  Use this with all the functions--- from the Heist API.-liftHeist :: HeistT (Handler b b) a -> SnapletHeist b v a-liftHeist = SnapletHeist . lift------------------------------------------------------------------------------------ | Common idiom for the combination of liftHandler and withTop.-liftWith :: (Lens (Snaplet b) (Snaplet v'))-         -> Handler b v' a-         -> SnapletHeist b v a-liftWith l = liftHeist . lift . withTop' l------------------------------------------------------------------------------------ | Lifts a Handler into SnapletHeist.-liftHandler :: Handler b v a -> SnapletHeist b v a-liftHandler m = do-    l <- ask-    liftWith l m------------------------------------------------------------------------------------ | Lifts a (Handler b b) into SnapletHeist.-liftAppHandler :: Handler b b a -> SnapletHeist b v a-liftAppHandler = liftHeist . lift---instance MonadState v (SnapletHeist b v) where-    get = do-        l <- ask-        b <- liftAppHandler getSnapletState-        return $ getL (snapletValue . l) b-    put s = do-        l <- ask-        b <- liftAppHandler getSnapletState-        liftAppHandler $ putSnapletState $ setL (snapletValue . l) s b------------------------------------------------------------------------------------ | MonadSnaplet instance gives us access to the snaplet infrastructure.-instance MonadSnaplet SnapletHeist where-    getLens = ask-    with' l = withSS (l .)-    withTop' l = withSS (const id) . with' l-    getOpaqueConfig = do-        l <- ask-        b <- liftAppHandler getSnapletState-        return $ getL (snapletConfig . l) b------------------------------------------------------------------------------------ | SnapletSplices version of bindSplices.-bindSnapletSplices :: (Lens (Snaplet b) (Snaplet v))-                   -> [(Text, SnapletSplice b v)]-                   -> TemplateState (Handler b b)-                   -> TemplateState (Handler b b)-bindSnapletSplices l splices =-    bindSplices $ map (second $ runSnapletSplice l) splices+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-------------------------------------------------------------------------------+                          ---------------------------+                          -- Initializer functions --+                          ---------------------------   --------------------------------------------------------------------------------- | The 'Initializer' for 'Heist'.  This function is a convenience wrapper--- around `heistInit'` that uses the default `emptyTemplateState` from Heist--- and sets up routes for all the templates.+-- | 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+              -- ^ Path to templates           -> SnapletInit b (Heist b)-heistInit templateDir = do-    makeSnaplet "heist" "" Nothing $ do-        hs <- heistInitWorker templateDir emptyTemplateState-        addRoutes [ ("", heistServe) ]-        return hs+heistInit = gHeistInit heistServe   ------------------------------------------------------------------------------ -- | A lower level 'Initializer' for 'Heist'.  This initializer requires you--- to specify the initial TemplateState.  It also does not add any routes for+-- 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-           -> TemplateState (Handler b b)-           -- ^ Initial TemplateState+               -- ^ Path to templates+           -> HeistConfig (Handler b b)+               -- ^ Initial HeistConfig            -> SnapletInit b (Heist b)-heistInit' templateDir initialTemplateState =-    makeSnaplet "heist" "" Nothing $-        heistInitWorker templateDir initialTemplateState+heistInit' templateDir initialConfig =+    makeSnaplet "heist" "" Nothing $ heistInitWorker templateDir initialConfig   --------------------------------------------------------------------------------- | Internal worker function used by variantsof heistInit.  This is necessary--- because of the divide between SnapletInit and Initializer.-heistInitWorker :: FilePath-                -> TemplateState (Handler b b)-                -> Initializer b v (Heist b)-heistInitWorker templateDir initialTemplateState = do-    (cacheFunc, cts) <- liftIO mkCacheTag-    let origTs = cacheFunc initialTemplateState-    ts <- liftIO $ loadTemplates templateDir origTs >>=-                   either error return-    printInfo $ T.pack $ unwords-        [ "...loaded"-        , (show $ length $ templateNames ts)-        , "templates"-        ]--    return $ Heist ts cts+-- | 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),()))  -addTemplates :: ByteString-             -- ^ Path to templates (also the url prefix for their routes)+------------------------------------------------------------------------------+-- | 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 urlPrefix = do+addTemplates h urlPrefix = do     snapletPath <- getSnapletFilePath-    addTemplatesAt urlPrefix (snapletPath </> "templates")+    addTemplatesAt h urlPrefix (snapletPath </> "templates")  -addTemplatesAt :: ByteString-               -- ^ URL prefix for template routes+------------------------------------------------------------------------------+-- | 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+                   -- ^ Path to templates                -> Initializer b (Heist b) ()-addTemplatesAt urlPrefix templateDir = do-    ts <- liftIO $ loadTemplates templateDir emptyTemplateState-                   >>= either error return+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 $ length $ templateNames ts)+        , (show $ Map.size ts)         , "templates from"         , templateDir         , "with route prefix"-        , (U.toString urlPrefix) ++ "/"+        , fullPrefix ++ "/"         ]-    addPostInitHook $ return . changeTS-        (`mappend` addTemplatePathPrefix urlPrefix ts)+    let locations = [fmap addPrefix <$> loadTemplates templateDir]+        add (hc, dm) =+          ((over hcTemplateLocations (mappend locations) hc, dm), ())+    liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) add  -modifyHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))-               -> (TemplateState (Handler b b) -> TemplateState (Handler b b))-               -> Initializer b v ()-modifyHeistTS' heist f = do-    _lens <- getLens-    withTop' heist $ addPostInitHook $ return . changeTS f+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."  -modifyHeistTS :: (Lens b (Snaplet (Heist b)))-              -> (TemplateState (Handler b b) -> TemplateState (Handler b b))-              -> Initializer b v ()-modifyHeistTS heist f = modifyHeistTS' (subSnaplet heist) f+------------------------------------------------------------------------------+getHeistState :: SnapletLens (Snaplet b) (Heist b)+              -> Handler b v (HeistState (Handler b b))+getHeistState heist = withTop' heist $ gets _heistState  -withHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))-             -> (TemplateState (Handler b b) -> a)-             -> Handler b v a-withHeistTS' heist f = withTop' heist $ gets (f . _heistTS)+------------------------------------------------------------------------------+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  -withHeistTS :: (Lens b (Snaplet (Heist b)))-            -> (TemplateState (Handler b b) -> a)-            -> Handler b v a-withHeistTS heist f = withHeistTS' (subSnaplet heist) f+------------------------------------------------------------------------------+modifyHeistState :: SnapletLens b (Heist b)+                 -> (HeistState (Handler b b) -> HeistState (Handler b b))+                 -> Initializer b v ()+modifyHeistState heist f = modifyHeistState' (subSnaplet heist) f  -addSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))-            -> [(Text, SnapletSplice b v)]-            -> Initializer b v ()-addSplices' heist splices = do-    _lens <- getLens-    withTop' heist $ addPostInitHook $-        return . changeTS (bindSnapletSplices _lens splices)+------------------------------------------------------------------------------+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  -addSplices :: (Lens b (Snaplet (Heist b)))-           -> [(Text, SnapletSplice b v)]-           -> Initializer b v ()-addSplices heist splices = addSplices' (subSnaplet heist) splices+------------------------------------------------------------------------------+withHeistState :: SnapletLens b (Heist b)+               -> (HeistState (Handler b b) -> a)+               -> Handler b v a+withHeistState heist f = withHeistState' (subSnaplet heist) f   --------------------------------------------------------------------------------- Handler functions-------------------------------------------------------------------------------+-- | 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.-renderHelper :: Maybe MIMEType+iRenderHelper :: Maybe MIMEType              -> ByteString              -> Handler b (Heist b) ()-renderHelper c t = do-    (Heist ts _) <- get-    withTop' id $ renderTemplate ts t >>= maybe pass serve+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+           -- ^ Name of the template        -> Handler b (Heist b) ()-render t = renderHelper Nothing t+render t = iRenderHelper Nothing t  +------------------------------------------------------------------------------ renderAs :: ByteString-         -- ^ Content type+             -- ^ Content type          -> ByteString-         -- ^ Name of the template+             -- ^ Name of the template          -> Handler b (Heist b) ()-renderAs ct t = renderHelper (Just ct) t+renderAs ct t = iRenderHelper (Just ct) t  +------------------------------------------------------------------------------ heistServe :: Handler b (Heist b) () heistServe =-    ifTop (render "index") <|> (render . B.pack =<< getSafePath)+    ifTop (render "index") <|> (render =<< serveURI)  -heistServeSingle :: ByteString-                 -> Handler b (Heist b) ()+------------------------------------------------------------------------------+heistServeSingle :: ByteString -> Handler b (Heist b) () heistServeSingle t =     render t <|> error ("Template " ++ show t ++ " not found.")  -heistLocal' :: (Lens (Snaplet b) (Snaplet (Heist b)))-            -> (TemplateState (Handler b b) -> TemplateState (Handler b b))+------------------------------------------------------------------------------+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 $ changeTS f+    withTop' heist $ modify $ changeState f     res <- m     withTop' heist $ put hs     return res  -heistLocal :: (Lens b (Snaplet (Heist b)))-           -> (TemplateState (Handler b b) -> TemplateState (Handler b b))+------------------------------------------------------------------------------+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' :: (Lens (Snaplet b) (Snaplet (Heist b)))-             -> [(Text, SnapletSplice b v)]+------------------------------------------------------------------------------+withSplices' :: SnapletLens (Snaplet b) (Heist b)+             -> Splices (SnapletISplice b)              -> Handler b v a              -> Handler b v a withSplices' heist splices m = do-    _lens <- getLens-    heistLocal' heist (bindSnapletSplices _lens splices) m+    heistLocal' heist (I.bindSplices splices) m  -withSplices :: (Lens b (Snaplet (Heist b)))-            -> [(Text, SnapletSplice b v)]+------------------------------------------------------------------------------+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' :: (Lens (Snaplet b) (Snaplet (Heist b)))+------------------------------------------------------------------------------+renderWithSplices' :: SnapletLens (Snaplet b) (Heist b)                    -> ByteString-                   -> [(Text, SnapletSplice b v)]+                   -> Splices (SnapletISplice b)                    -> Handler b v () renderWithSplices' heist t splices =     withSplices' heist splices $ withTop' heist $ render t  -renderWithSplices :: (Lens b (Snaplet (Heist b)))+------------------------------------------------------------------------------+renderWithSplices :: SnapletLens b (Heist b)                   -> ByteString-                  -> [(Text, SnapletSplice b v)]+                  -> Splices (SnapletISplice b)                   -> Handler b v () renderWithSplices heist t splices =     renderWithSplices' (subSnaplet heist) t splices--
src/Snap/Snaplet/Internal/Initializer.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}  module Snap.Snaplet.Internal.Initializer   ( addPostInitHook@@ -13,42 +14,70 @@   , nameSnaplet   , onUnload   , addRoutes-  , wrapHandlers+  , wrapSite   , runInitializer   , runSnaplet   , combineConfig   , serveSnaplet+  , serveSnapletNoArgParsing+  , loadAppConfig   , printInfo+  , getRoutes+  , getEnvironment+  , modifyMaster   ) where -import           Prelude hiding ((.), id, catch)-import           Control.Category-import           Control.Concurrent.MVar-import           Control.Exception (SomeException)-import           Control.Monad-import           Control.Monad.CatchIO hiding (Handler)-import           Control.Monad.Reader-import           Control.Monad.State-import           Control.Monad.Trans.Writer hiding (pass)-import           Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B-import           Data.Configurator-import           Data.IORef-import           Data.Maybe-import           Data.Lens.Lazy-import           Data.Text (Text)-import qualified Data.Text as T-import           Snap.Http.Server-import           Snap.Core-import           Snap.Util.GZip-import           System.Directory-import           System.Directory.Tree-import           System.FilePath.Posix-import           System.IO--import qualified Snap.Snaplet.Internal.LensT as LT+------------------------------------------------------------------------------+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+------------------------------------------------------------------------------   ------------------------------------------------------------------------------@@ -74,11 +103,26 @@   ------------------------------------------------------------------------------+-- | 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 v) -> (Snaplet v -> IO (Snaplet v))-toSnapletHook f (Snaplet cfg val) = do+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 val'+    return $! Snaplet cfg reset <$> val'   ------------------------------------------------------------------------------@@ -89,11 +133,13 @@ -- 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 v) -> Initializer b v ()+addPostInitHook :: (v -> IO (Either Text v))+                -> Initializer b v () addPostInitHook = addPostInitHook' . toSnapletHook  -addPostInitHook' :: (Snaplet v -> IO (Snaplet v)) -> Initializer b v ()+addPostInitHook' :: (Snaplet v -> IO (Either Text (Snaplet v)))+                 -> Initializer b v () addPostInitHook' h = do     h' <- upHook h     addPostInitHookBase h'@@ -101,15 +147,15 @@  ------------------------------------------------------------------------------ -- | Variant of addPostInitHook for when you have things wrapped in a Snaplet.-addPostInitHookBase :: (Snaplet b -> IO (Snaplet b))+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 (Snaplet v))-       -> Initializer b v (Snaplet b -> IO (Snaplet b))+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@@ -117,27 +163,29 @@  ------------------------------------------------------------------------------ -- | Helper function for transforming hooks.-upHook' :: (Lens b a) -> (a -> IO a) -> b -> IO b+upHook' :: Monad m => ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b) upHook' l h b = do-    v <- h (getL l b)-    return $ setL l v b+    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 $ modL curConfig $ \c -> f c+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.+                    -- ^ 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.+                    -- ^ Directory where the files should be copied.                 -> Initializer b v () setupFilesystem Nothing _ = return () setupFilesystem (Just getSnapletDataDir) targetDir = do@@ -146,11 +194,15 @@         printInfo "...setting up filesystem"         liftIO $ createDirectoryIfMissing True targetDir         srcDir <- liftIO getSnapletDataDir-        (_ :/ dTree) <- liftIO $ readDirectoryWith B.readFile srcDir-        let (topDir,snapletId) = splitFileName targetDir-        _ <- liftIO $ writeDirectoryWith B.writeFile-               (topDir :/ dTree { name = snapletId })+        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   ------------------------------------------------------------------------------@@ -170,31 +222,34 @@ -- 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+                -- ^ 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 setL scId (Just snapletId) c else c+        then set scId (Just snapletId) c else c     sid <- iGets (T.unpack . fromJust . _scId . _curConfig)     topLevel <- iGets _isTopLevel-    unless topLevel $ modifyCfg $ \c -> setL scFilePath-        (_scFilePath c </> "snaplets" </> sid) c-    iModify (setL isTopLevel False)-    modifyCfg $ modL scUserConfig (subconfig (T.pack sid))-    modifyCfg $ setL scDescription desc+    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 "@@ -204,10 +259,12 @@       ]      -- This has to happen here because it needs to be after scFilePath is set-    -- up but before snaplet.cfg is read.+    -- up but before the config file is read.     setupFilesystem getSnapletDataDir (_scFilePath cfg) -    liftIO $ addToConfig [Optional (_scFilePath cfg </> "snaplet.cfg")]+    env <- iGets _environment+    let configLocation = _scFilePath cfg </> (env ++ ".cfg")+    liftIO $ addToConfig [Optional configLocation]                          (_scUserConfig cfg)     mkSnaplet m @@ -215,13 +272,17 @@ ------------------------------------------------------------------------------ -- | Internal function that gets the SnapletConfig out of the initializer -- state and uses it to create a (Snaplet a).-mkSnaplet :: Initializer b v a -> Initializer b v (Snaplet a)+mkSnaplet :: Initializer b v v -> Initializer b v (Snaplet v) mkSnaplet m = do     res <- m     cfg <- iGets _curConfig-    return $ Snaplet cfg res+    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.@@ -229,7 +290,7 @@ bracketInit m = do     s <- iGet     res <- m-    iModify (setL curConfig (_curConfig s))+    iModify (set curConfig (_curConfig s))     return res  @@ -239,9 +300,9 @@ setupSnapletCall :: ByteString -> Initializer b v () setupSnapletCall rte = do     curId <- iGets (fromJust . _scId . _curConfig)-    modifyCfg (modL scAncestry (curId:))-    modifyCfg (modL scId (const Nothing))-    unless (B.null rte) $ modifyCfg (modL scRouteContext (rte:))+    modifyCfg (over scAncestry (curId:))+    modifyCfg (over scId (const Nothing))+    unless (B.null rte) $ modifyCfg (over scRouteContext (rte:))   ------------------------------------------------------------------------------@@ -251,73 +312,86 @@ -- 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.-            -> (Lens v (Snaplet v1))-            -- ^ Lens identifying the snaplet+                -- ^ 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.+                -- ^ The initializer function for the subsnaplet.             -> Initializer b v (Snaplet v1)-nestSnaplet rte l (SnapletInit snaplet) = with l $ bracketInit $ do-    setupSnapletCall rte-    snaplet+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+-- 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 top-level, 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.+-- 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.-             -> (Lens v (Snaplet v1))-             -- ^ Lens identifying the snaplet+                 -- ^ 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.+                -- ^ The initializer function for the subsnaplet.              -> Initializer b v (Snaplet v1) embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do     curLens <- getLens-    setupSnapletCall rte-    chroot rte (subSnaplet l . curLens) snaplet+    setupSnapletCall ""+    chroot rte (cloneLens curLens . subSnaplet l) snaplet   ------------------------------------------------------------------------------ -- | Changes the base state of an initializer. chroot :: ByteString-       -> (Lens (Snaplet b) (Snaplet v1))+       -> 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+          _hFilter = id,+          masterReloader = newSetter         }     let handler = chrootHandler l $ _hFilter s $ route $ _handlers s-    iModify $ modL handlers (++[(rte,handler)])-            . setL cleanup (_cleanup s)+    iModify $ over handlers (++[(rte,handler)])+            . set cleanup (_cleanup s)     addPostInitHookBase $ upHook' l hook     return a   ------------------------------------------------------------------------------ -- | Changes the base state of a handler.-chrootHandler :: (Lens (Snaplet v) (Snaplet b'))+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 (getL l s)-    modify $ setL l s'+    (a, s') <- liftSnap $ L.runLensed h id (s ^# l)+    modify $ storing l s'     return a  @@ -330,12 +404,12 @@ -- -- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@ nameSnaplet :: Text-            -- ^ The snaplet name+                -- ^ The snaplet name             -> SnapletInit b v-            -- ^ The snaplet initializer function+                -- ^ The snaplet initializer function             -> SnapletInit b v nameSnaplet nm (SnapletInit m) = SnapletInit $-    modifyCfg (setL scId (Just nm)) >> m+    modifyCfg (set scId (Just nm)) >> m   ------------------------------------------------------------------------------@@ -350,7 +424,7 @@     let modRoute (r,h) = ( buildPath (r:ctx)                          , setPattern r >> withTop' l h)     let rs' = map modRoute rs-    iModify (\v -> modL handlers (++rs') v)+    iModify (\v -> over handlers (++rs') v)   where     setPattern r = do       p <- getRoutePattern@@ -358,13 +432,20 @@   --------------------------------------------------------------------------------- | Wraps the snaplet's routing.  This can be used to provide a snaplet that--- does per-request setup and cleanup, but then dispatches to the rest of the--- application.-wrapHandlers :: (Handler b v () -> Handler b v ()) -> Initializer b v ()-wrapHandlers f0 = do+-- | 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 -> modL hFilter (f.) v)+    iModify (\v -> over hFilter (f.) v)   ------------------------------------------------------------------------------@@ -381,7 +462,11 @@ -- | 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 = iModify (\v -> modL cleanup (m>>) v)+onUnload m = do+    cleanupRef <- iGets _cleanup+    liftIO $ atomicModifyIORef cleanupRef f+  where+    f curCleanup = (curCleanup >> m, ())   ------------------------------------------------------------------------------@@ -403,19 +488,21 @@  ------------------------------------------------------------------------------ -- | Builds an IO reload action for storage in the SnapletState.-mkReloader :: MVar (Snaplet b)+mkReloader :: FilePath+           -> String+           -> ((Snaplet b -> Snaplet b) -> IO ())+           -> IORef (IO ())            -> Initializer b b (Snaplet b)-           -> IO (Either String String)-mkReloader mvar i = do-    !res <- try $ runInitializer mvar i-    either bad good res+           -> 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-    bad e = do-        return $ Left $ show (e :: SomeException)     good (b,is) = do-        _ <- swapMVar mvar b+        _ <- resetter (const b)         msgs <- readIORef $ _initMessages is-        return $ Right $ T.unpack msgs+        return $ Right msgs   ------------------------------------------------------------------------------@@ -430,38 +517,87 @@   --------------------------------------------------------------------------------- |-runInitializer :: MVar (Snaplet b)+-- | 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 (Snaplet b, InitializerState b)-runInitializer mvar b@(Initializer i) = do-    userConfig <- load [Optional "snaplet.cfg"]+               -> 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 [] "" Nothing "" userConfig [] Nothing-                            (mkReloader mvar b)+    let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing reloader_     logRef <- newIORef ""-    ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $-        InitializerState True (return ()) builtinHandlers id cfg logRef-    res' <- hook res-    return (res', s) +    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' ---------------------------------------------------------------------------------- | Given a Snaplet initializer, produce the set of messages generated during--- initialization, a snap handler, and a cleanup action.-runSnaplet :: SnapletInit b b -> IO (Text, Snap (), IO ())-runSnaplet (SnapletInit b) = do-    snapletMVar <- newEmptyMVar-    (siteSnaplet, is) <- runInitializer snapletMVar b-    putMVar snapletMVar siteSnaplet+        handler e = do+            join $ readIORef cleanupRef+            logMessages <- readIORef logRef -    msgs <- liftIO $ readIORef $ _initMessages is-    let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar+            return $ Left $ T.unlines+                [ "Initializer threw an exception..."+                , T.pack $ show (e :: SomeException)+                , ""+                , "...but before it died it generated the following output:"+                , logMessages+                ] -    return (msgs, handler, _cleanup is)+    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.@@ -478,19 +614,92 @@   --------------------------------------------------------------------------------- | Serves a top-level snaplet as a web application. Reads command-line--- arguments. FIXME: document this.-serveSnaplet :: Config Snap a -> SnapletInit b b -> IO ()+-- | 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-    (msgs, handler, doCleanup) <- runSnaplet initializer+    config <- commandLineAppConfig startConfig+    serveSnapletNoArgParsing config initializer -    config       <- commandLineConfig startConfig+------------------------------------------------------------------------------+-- | 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-    let serve = simpleHttpServe conf+    createDirectoryIfMissing False "log"+    let serve = httpServe conf -    liftIO $ hPutStrLn stderr $ T.unpack msgs+    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 _ _ = []+  
src/Snap/Snaplet/Internal/LensT.hs view
@@ -2,83 +2,114 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}  module Snap.Snaplet.Internal.LensT where -import           Control.Applicative-import           Control.Category-import           Control.Monad.CatchIO-import           Control.Monad.Reader-import           Control.Monad.State.Class-import           Data.Lens.Lazy-import           Prelude hiding ((.), id, catch)-import           Snap.Core -import           Snap.Snaplet.Internal.RST+------------------------------------------------------------------------------+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 (Lens b v) s m a)+newtype LensT b v s m a = LensT (RST (ALens' b v) s m a)   deriving ( Monad            , MonadTrans            , Functor            , Applicative            , MonadIO            , MonadPlus-           , MonadCatchIO            , Alternative-           , MonadReader (Lens b v)-           , MonadSnap )+           , MonadReader (ALens' b v))   -------------------------------------------------------------------------------instance (Monad m) => MonadState v (LensT b v b m) where+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 :: Monad m => LensT b v s m s getBase = LensT get {-# INLINE getBase #-}   -------------------------------------------------------------------------------putBase :: (Monad m) => s -> LensT b v s m ()+putBase :: Monad m => s -> LensT b v s m () putBase = LensT . put {-# INLINE putBase #-}   -------------------------------------------------------------------------------lGet :: (Monad m) => LensT b v b m v+lGet :: Monad m => LensT b v b m v lGet = LensT $ do            !l <- ask            !b <- get-           return $! l ^$ b+           return $! b ^# l {-# INLINE lGet #-}   -------------------------------------------------------------------------------lPut :: (Monad m) => v -> LensT b v b m ()+lPut :: Monad m => v -> LensT b v b m () lPut v = LensT $ do              !l <- ask              !b <- get-             put $! (l ^!= v) b+             put $! storing l v b {-# INLINE lPut #-}   -------------------------------------------------------------------------------runLensT :: (Monad m) =>-            LensT b v s m a-         -> Lens b v-         -> s-         -> m (a, s)-runLensT (LensT m) = runRST m+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 =>-             ((Lens b' v') -> (Lens b v))+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@@ -87,19 +118,14 @@  ------------------------------------------------------------------------------ withTop :: Monad m-        => (Lens b v')+        => ALens' b v'         -> LensT b v' s m a         -> LensT b v  s m a-withTop !subLens = withLensT (const subLens)+withTop subLens = withLensT (const subLens) {-# INLINE withTop #-}   -------------------------------------------------------------------------------with :: Monad m-     => (Lens v v')-     -> LensT b v' s m a-     -> LensT b v  s m a-with !subLens = withLensT (subLens .)-{-# INLINE with #-}-+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) 
src/Snap/Snaplet/Internal/Lensed.hs view
@@ -1,24 +1,36 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}  module Snap.Snaplet.Internal.Lensed where -import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Data.Lens.Strict-import Control.Monad.CatchIO-import Control.Monad.Reader.Class-import Control.Monad.State.Class-import Control.Monad.State.Strict-import Control.Category-import Prelude hiding (catch, id, (.))-import Snap.Core +------------------------------------------------------------------------------+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 :: Lens b v -> v -> b -> m (a, v, b) }+    { unlensed :: ALens' b v -> v -> b -> m (a, v, b) }   ------------------------------------------------------------------------------@@ -36,6 +48,11 @@   ------------------------------------------------------------------------------+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@@ -49,20 +66,21 @@     put v' = Lensed $ \_ _ s -> return ((), v', s)  --------------------------------------------------------------------------------instance Monad m => MonadReader (Lens b v) (Lensed b v m) where-    ask = Lensed $ \l v s -> return (l, v, s)-    local f g = do-        l' <- asks f-        withTop l' g+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)-+      res <- m+      return (res, v, b)  ------------------------------------------------------------------------------ instance MonadIO m => MonadIO (Lensed b v m) where@@ -70,17 +88,6 @@   -------------------------------------------------------------------------------instance MonadCatchIO m => MonadCatchIO (Lensed b v m) where-    catch (Lensed m) f = Lensed $ \l v b -> m l v b `catch` handler l v b-      where-        handler l v b e = let (Lensed h) = f e-                          in h l v b--    block (Lensed m)   = Lensed $ \l v b -> block (m l v b)-    unblock (Lensed m) = Lensed $ \l v b -> unblock (m l v b)--------------------------------------------------------------------------------- instance MonadPlus m => MonadPlus (Lensed b v m) where     mzero = lift mzero     m `mplus` n = Lensed $ \l v b ->@@ -90,7 +97,7 @@ ------------------------------------------------------------------------------ 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+    Lensed m <|> Lensed n = Lensed $ \l v b -> m l v b <|> n l v b   ------------------------------------------------------------------------------@@ -99,53 +106,77 @@   ------------------------------------------------------------------------------+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 => Lens b v' -> Lensed b v' m a -> Lensed b v m a+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 => Lens v v' -> Lensed b v' m a -> Lensed b v m a+with :: Monad m => ALens' v v' -> Lensed b v' m a -> Lensed b v m a with l g = do-    l' <- asks (l .)-    withTop l' g+    l' <- ask+    withTop (cloneLens l' . l) g   -------------------------------------------------------------------------------embed :: Monad m => Lens v v' -> Lensed v v' m a -> Lensed b v m a+embed :: Monad m => ALens' v v' -> Lensed v v' m a -> Lensed b v m a embed l m = locally $ lensedAsState m l   -------------------------------------------------------------------------------globally :: Monad m => StateT b m a -> Lensed b v m a-globally (StateT f) = Lensed $ \l v s ->-                      liftM (\(a, s') -> (a, l ^$ s', s')) $ f (l ^= v $ s)--------------------------------------------------------------------------------- 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   -------------------------------------------------------------------------------lensedAsState :: Monad m => Lensed b v m a -> Lens b v -> StateT b m a-lensedAsState (Lensed f) l = StateT $ \s -> do-    (a, v', s') <- f l (l ^$ s) s-    return (a, l ^= v' $ s')--------------------------------------------------------------------------------- runLensed :: Monad m           => Lensed t1 b m t-          -> Lens t1 b+          -> ALens' t1 b           -> t1           -> m (t, t1) runLensed (Lensed f) l s = do-    (a, v', s') <- f l (l ^$ s) s-    return (a, l ^= v' $ s')-+    (a, v', s') <- f l (s ^# l) s+    return (a, storing l v' s')
src/Snap/Snaplet/Internal/RST.hs view
@@ -1,16 +1,24 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}  module Snap.Snaplet.Internal.RST where -import           Control.Applicative-import           Control.Category-import           Control.Monad.CatchIO-import           Control.Monad.Reader-import           Control.Monad.State.Class-import           Prelude hiding ((.), id, catch)-import           Snap.Core+import           Control.Applicative         (Alternative (..),+                                              Applicative (..))+import           Control.Monad+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           Snap.Core                   (MonadSnap (..))   ------------------------------------------------------------------------------@@ -66,12 +74,6 @@ mapRST f m = RST $ \r s -> f (runRST m r s)  -instance (MonadCatchIO m) => MonadCatchIO (RST r s m) where-    m `catch` f = RST $ \r s -> runRST m r s-                           `catch` \e -> runRST (f e) r s-    block       = mapRST block-    unblock     = mapRST unblock- instance (MonadSnap m) => MonadSnap (RST r s m) where     liftSnap s = lift $ liftSnap s @@ -89,21 +91,45 @@ instance (Monad m) => Monad (RST r s m) where     return a = RST $ \_ s -> return (a, s)     (>>=)    = rwsBind+#if !MIN_VERSION_base(4,13,0)     fail msg = RST $ \_ _ -> fail msg+#endif +instance Fail.MonadFail m => Fail.MonadFail (RST r s m) where+    fail msg = RST $ \_ _ -> Fail.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 (MonadIO m) => MonadIO (RST r s m) where-    liftIO = lift . liftIO +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 #-}
src/Snap/Snaplet/Internal/Types.hs view
@@ -1,35 +1,52 @@ {-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImpredicativeTypes         #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE TypeFamilies               #-} +#ifndef MIN_VERSION_comonad+#define MIN_VERSION_comonad(x,y,z) 1+#endif+ module Snap.Snaplet.Internal.Types where -import           Prelude hiding ((.), id)-import           Control.Applicative-import           Control.Category ((.), id)-import           Control.Monad.CatchIO hiding (Handler)-import           Control.Monad.Reader-import           Control.Monad.State.Class-import           Control.Monad.Trans.Writer hiding (pass)-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import           Data.Configurator.Types-import           Data.IORef-import           Data.Monoid-import           Data.Lens.Lazy-import           Data.Lens.Template-import           Data.Text (Text)-import qualified Data.Text as T+------------------------------------------------------------------------------+import           Control.Applicative          (Alternative)+import           Control.Lens                 (ALens', makeLenses, set)+import           Control.Monad                (MonadPlus, liftM)+import           Control.Monad.Base           (MonadBase (..))+import           Control.Monad.Fail           (MonadFail)+import           Control.Monad.Reader         (MonadIO (..), 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) -import           Snap.Core-import qualified Snap.Snaplet.Internal.LensT as LT-import qualified Snap.Snaplet.Internal.Lensed as L+#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.@@ -41,16 +58,23 @@     , _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 String String) -- might change+        -- ^ 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 "/" $ reverse ps+buildPath ps = B.intercalate "/" $ filter (not . B.null) $ reverse ps   ------------------------------------------------------------------------------@@ -69,30 +93,65 @@ --   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-    , _snapletValue  :: s+    { _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 [''SnapletConfig, ''Snaplet]+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 :: Lens (Snaplet a) SnapletConfig+snapletConfig :: SimpleLens (Snaplet a) SnapletConfig   ------------------------------------------------------------------------------ -- | A lens referencing the user-defined state type wrapped by a Snaplet.-snapletValue :: Lens (Snaplet a) a+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 :: (Lens a (Snaplet b)) -> (Lens (Snaplet a) (Snaplet b))-subSnaplet = (. snapletValue)+subSnaplet :: SnapletLens a b+           -> SnapletLens (Snaplet a) b+subSnaplet l = snapletValue . l   ------------------------------------------------------------------------------@@ -109,21 +168,21 @@     -- 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 :: (Lens v (Snaplet v'))-         -- ^ A relative lens identifying a snaplet+    with :: SnapletLens v v'+             -- ^ A relative lens identifying a snaplet          -> m b v' a-         -- ^ Action from the lense's snaplet+             -- ^ Action from the lense's snaplet          -> m b v a-    with = with' . subSnaplet+    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 :: (Lens b (Snaplet v'))-            -- ^ An \"absolute\" lens identifying a snaplet+    withTop :: SnapletLens b v'+                -- ^ An \"absolute\" lens identifying a snaplet             -> m b v' a-            -- ^ Action from the lense's snaplet+                -- ^ Action from the lense's snaplet             -> m b v a     withTop l = withTop' (subSnaplet l) @@ -134,7 +193,8 @@     -- however the lens returned by 'getLens' will.     --     -- @with = with' . subSnaplet@-    with' :: (Lens (Snaplet v) (Snaplet v')) -> m b v' a -> m b v a+    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@@ -142,10 +202,11 @@     -- with' l m = flip withTop m . (l .) =<< getLens      -- | The absolute version of 'with''-    withTop' :: (Lens (Snaplet b) (Snaplet v')) -> m b v' a -> m b v a+    withTop' :: SnapletLens (Snaplet b) v'+             -> m b v' a -> m b v a      -- | Gets the lens for the current snaplet.-    getLens :: m b v (Lens (Snaplet b) (Snaplet v))+    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.@@ -193,6 +254,18 @@   ------------------------------------------------------------------------------+-- | 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@@ -201,18 +274,39 @@ -- 'MonadSnaplet' instance, which gives you all the functionality described -- above. newtype Handler b v a =-    Handler (L.Lensed (Snaplet b) (Snaplet v) Snap a)+    Handler { _unHandler :: L.Lensed (Snaplet b) (Snaplet v) Snap a }   deriving ( Monad            , Functor            , Applicative+           , MonadFail            , MonadIO            , MonadPlus-           , MonadCatchIO            , 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@@ -242,12 +336,27 @@   --------------------------------------------------------------------------------- | The MonadState instance gives you access to the current snaplet's state.+-- | 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 (setL snapletValue v)+    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@@ -256,10 +365,19 @@   ------------------------------------------------------------------------------+-- | 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+getRoutePattern =+    withTop' id $ liftM _scRoutePattern getOpaqueConfig   ------------------------------------------------------------------------------@@ -268,10 +386,28 @@ -- addRoutes. setRoutePattern :: ByteString -> Handler b v () setRoutePattern p = withTop' id $-    modifySnapletState (setL (scRoutePattern . snapletConfig) (Just p))+    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@@ -281,45 +417,80 @@   where     bad msg = do         writeText $ "Error reloading site!\n\n"-        writeText $ T.pack msg+        writeText msg     good msg = do-        writeText $ T.pack msg+        writeText msg         writeText $ "Site successfully reloaded.\n"-    failIfNotLocal m = do-        rip <- liftM rqRemoteAddr getRequest-        if not $ elem rip [ "127.0.0.1"-                          , "localhost"-                          , "::1" ]-          then pass-          else m   ------------------------------------------------------------------------------+-- | 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         :: IO ()+    , _cleanup         :: IORef (IO ())     , _handlers        :: [(ByteString, Handler b b ())]-    -- ^ Handler routes built up and passed to route.+        -- ^ Handler routes built up and passed to route.     , _hFilter         :: Handler b b () -> Handler b b ()-    -- ^ Generic filtering of handlers+        -- ^ Generic filtering of handlers     , _curConfig       :: SnapletConfig-    -- ^ This snaplet config is the incrementally built config for whatever-    -- snaplet is currently being constructed.+        -- ^ 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 (Snaplet a))+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-    (Hook a) `mappend` (Hook b) = Hook (a >=> b)+    mempty = Hook (return . Right)+#if !MIN_VERSION_base(4,11,0)+    mappend = (<>)+#endif   ------------------------------------------------------------------------------@@ -332,9 +503,10 @@                           a)   deriving (Applicative, Functor, Monad, MonadIO) -makeLenses [''InitializerState]+makeLenses ''InitializerState  +------------------------------------------------------------------------------ instance MonadSnaplet Initializer where     getLens = Initializer ask     with' !l (Initializer !m) = Initializer $ LT.with l m@@ -346,14 +518,3 @@ -- | 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))------------------------------------------------------------------------------------ | Information needed to reload a site.  Instead of having snaplets define--- their own reload actions, we store the original site initializer and use it--- instead.-data ReloadInfo b = ReloadInfo-    { riRef     :: IORef (Snaplet b)-    , riAction  :: Initializer b b b-    }-
src/Snap/Snaplet/Session.hs view
@@ -1,7 +1,5 @@ module Snap.Snaplet.Session--(-    SessionManager+  ( SessionManager   , withSession   , commitSession   , setInSession@@ -12,96 +10,120 @@   , resetSession   , touchSession -) where+  -- * Utilities Exported For Convenience+  , module Snap.Snaplet.Session.Common+  , module Snap.Snaplet.Session.SecureCookie+  ) where +------------------------------------------------------------------------------ import           Control.Monad.State-import           Data.Lens.Lazy-import           Data.Text (Text)--import           Snap.Snaplet+import           Data.Text                           (Text) import           Snap.Core--import           Snap.Snaplet.Session.SessionManager-                   ( SessionManager(..), ISessionManager(..) )+------------------------------------------------------------------------------+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 :: (Lens b (Snaplet SessionManager))+--+withSession :: SnapletLens b SessionManager             -> Handler b v a             -> Handler b v a withSession l h = do-  a <- h-  withTop l commitSession-  return a+    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+    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'+    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+    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'+    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+    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+    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'+    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'+    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'+    SessionManager r <- get+    r' <- liftSnap $ load r+    return $ SessionManager r' 
src/Snap/Snaplet/Session/Backends/CookieSession.hs view
@@ -1,160 +1,205 @@-{-# LANGUAGE OverloadedStrings          #-}+------------------------------------------------------------------------------+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}  module Snap.Snaplet.Session.Backends.CookieSession--( initCookieSessionManager ) where+    ( initCookieSessionManager+    ) where +------------------------------------------------------------------------------ import           Control.Monad.Reader-import           Data.ByteString (ByteString)-import           Data.Generics-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM-import           Data.Hashable (Hashable)-import           Data.Serialize (Serialize)-import qualified Data.Serialize as S-import           Data.Text (Text)+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 -import           Snap.Core (Snap)+#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif+------------------------------------------------------------------------------ import           Snap.Snaplet-import           Snap.Snaplet.Session.Common (mkCSRFToken)+import           Snap.Snaplet.Session import           Snap.Snaplet.Session.SessionManager-import           Snap.Snaplet.Session.SecureCookie+-------------------------------------------------------------------------------  +------------------------------------------------------------------------------ -- | 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)+    { csCSRFToken :: Text+    , csSession   :: Session+    }+  deriving (Eq, Show)  +------------------------------------------------------------------------------ instance Serialize CookieSession where-  put (CookieSession a b) = S.put (a,b)-  get                     = (\(a,b) -> CookieSession a b) `fmap` S.get+    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 -instance (Serialize k, Serialize v, Hashable k, Eq k) =>-  Serialize (HashMap k v) where-  put = S.put . HM.toList-  get = HM.fromList `fmap` S.get +encodeTuple :: (Text, Text) -> (ByteString, ByteString)+encodeTuple (a,b) = (encodeUtf8 a, encodeUtf8 b) -mkCookieSession :: IO CookieSession-mkCookieSession = do-  t <- liftIO $ mkCSRFToken-  return $ CookieSession t HM.empty +decodeTuple :: (ByteString, ByteString) -> (Text, Text)+decodeTuple (a,b) = (decodeUtf8 a, decodeUtf8 b) --- | 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+------------------------------------------------------------------------------+mkCookieSession :: RNG -> IO CookieSession+mkCookieSession rng = do+    t <- liftIO $ mkCSRFToken rng+    return $ CookieSession t HM.empty -  , cookieName :: ByteString-  -- ^ Cookie name for the session system -  , timeOut :: Maybe Int-  -- ^ Session cookies will be considered "stale" after this many seconds.-} deriving (Show,Typeable)+------------------------------------------------------------------------------+-- | 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 _ _ _) = do-  case ses of-    Nothing -> do-      ses' <- mkCookieSession-      return $ mgr { session = Just ses' }-    Just _ -> return mgr+loadDefSession mgr@(CookieSessionManager ses _ _ _ _ rng) =+    case ses of+      Nothing -> do ses' <- mkCookieSession rng+                    return $! mgr { session = Just ses' }+      Just _  -> return mgr  +------------------------------------------------------------------------------ modSession :: (Session -> Session) -> CookieSession -> CookieSession modSession f (CookieSession t ses) = CookieSession t (f ses)  +------------------------------------------------------------------------------ -- | Initialize a cookie-backed session, returning a 'SessionManager' to be -- stuffed inside your application's state. This 'SessionManager' will enable -- the use of all session storage functionality defined in -- 'Snap.Snaplet.Session'+-- initCookieSessionManager-  :: FilePath             -- ^ Path to site-wide encryption key-  -> ByteString           -- ^ Session cookie name-  -> Maybe Int            -- ^ Session time-out (replay attack protection)-  -> SnapletInit b SessionManager-initCookieSessionManager fp cn to =-  makeSnaplet "CookieSession" "A snaplet providing sessions via HTTP cookies."-         Nothing $ liftIO $ do-    key <- getKey fp-    return . SessionManager $ CookieSessionManager Nothing key cn to+    :: 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 _ _ _) = do-    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 _ _ _) = do-    pl <- case r of-      Just r' -> return . Payload $ S.encode r'-      Nothing -> liftIO mkCookieSession >>= return . Payload . S.encode-    setPayload mgr pl+    --------------------------------------------------------------------------+    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 } -  reset mgr = do-    cs <- liftIO mkCookieSession-    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 -  touch = id+    --------------------------------------------------------------------------+    reset mgr = do+        cs <- liftIO $ mkCookieSession (randomNumberGenerator mgr)+        return $ mgr { session = Just cs } -  insert k v mgr@(CookieSessionManager r _ _ _) = case r of-    Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }-    Nothing -> mgr+    --------------------------------------------------------------------------+    touch = id -  lookup k (CookieSessionManager r _ _ _) = r >>= HM.lookup k . csSession+    --------------------------------------------------------------------------+    insert k v mgr@(CookieSessionManager r _ _ _ _ _) = case r of+        Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }+        Nothing -> mgr -  delete k mgr@(CookieSessionManager r _ _ _) = case r of-    Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }-    Nothing -> mgr+    --------------------------------------------------------------------------+    lookup k (CookieSessionManager r _ _ _ _ _) = r >>= HM.lookup k . csSession -  csrf (CookieSessionManager r _ _ _) = case r of-    Just r' -> csCSRFToken r'-    Nothing -> ""+    --------------------------------------------------------------------------+    delete k mgr@(CookieSessionManager r _ _ _ _ _) = case r of+        Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }+        Nothing -> mgr -  toList (CookieSessionManager r _ _ _) = case r of-    Just r' -> HM.toList . csSession $ r'-    Nothing -> []+    --------------------------------------------------------------------------+    csrf (CookieSessionManager r _ _ _ _ _) = case r of+        Just r' -> csCSRFToken r'+        Nothing -> "" +    --------------------------------------------------------------------------+    toList (CookieSessionManager r _ _ _ _ _) = case r of+        Just r' -> HM.toList . csSession $ r'+        Nothing -> []  +------------------------------------------------------------------------------ -- | A session payload to be stored in a SecureCookie. newtype Payload = Payload ByteString   deriving (Eq, Show, Ord, Serialize)  +------------------------------------------------------------------------------ -- | Get the current client-side value getPayload :: CookieSessionManager -> Snap (Maybe Payload) getPayload mgr = getSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr)  +------------------------------------------------------------------------------ -- | Set the client-side value setPayload :: CookieSessionManager -> Payload -> Snap ()-setPayload mgr x =-    setSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr) x--+setPayload mgr x = setSecureCookie (cookieName mgr) (cookieDomain mgr)+                                   (siteKey mgr) (timeOut mgr) x
src/Snap/Snaplet/Session/Common.hs view
@@ -1,41 +1,61 @@-{-|--  This module contains functionality common among multiple back-ends.---}--module Snap.Snaplet.Session.Common where+{-# LANGUAGE CPP               #-}+------------------------------------------------------------------------------+-- | This module contains functionality common among multiple back-ends.+-- +module Snap.Snaplet.Session.Common+  ( RNG+  , mkRNG+  , withRNG+  , randomToken+  , mkCSRFToken+  ) where -import           Numeric-import           Data.Serialize-import qualified Data.Serialize as S+------------------------------------------------------------------------------+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 + --------------------------------------------------------------------------------- | Generates a random salt of given length-randomToken :: Int -> IO ByteString-randomToken n =-  let-    mk :: GenIO -> IO Int-    mk gen = uniformR (0,15) gen-  in do-    is <- withSystemRandom $ \gen -> sequence . take n . repeat $ mk gen-    return . B.pack . concat . map (flip showHex "") $ is+-- | 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 + --------------------------------------------------------------------------------- | Generate a randomized CSRF token-mkCSRFToken :: IO Text-mkCSRFToken = T.decodeUtf8 `fmap` randomToken 40+-- | Create a new RNG+mkRNG :: IO RNG+mkRNG = withSystemRandom (newMVar >=> return . RNG)  -instance Serialize Text where-  put = S.put . T.encodeUtf8-  get = T.decodeUtf8 `fmap` S.get+------------------------------------------------------------------------------+-- | 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
src/Snap/Snaplet/Session/SecureCookie.hs view
@@ -1,42 +1,42 @@+{-# 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 where--import Control.Applicative-import Control.Monad-import Control.Monad.Trans--import Data.ByteString (ByteString)-import Data.Time-import Data.Time.Clock.POSIX--import Data.Serialize-import Web.ClientSession--import Snap.Core-+------------------------------------------------------------------------------+-- | 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  --------------------------------------------------------------------------------- | Serialize UTCTime-instance Serialize UTCTime where-    put t = put (round (utcTimeToPOSIXSeconds t) :: Integer)-    get   = posixSecondsToUTCTime . fromInteger <$> get+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.@@ -44,7 +44,7 @@   --------------------------------------------------------------------------------- Get the payload back+-- | Get the cookie payload. getSecureCookie :: (MonadSnap m, Serialize t)                 => ByteString       -- ^ Cookie name                 -> Key              -- ^ Encryption key@@ -52,45 +52,79 @@                 -> m (Maybe t) getSecureCookie name key timeout = do     rqCookie <- getCookie name-    rspCookie <- getResponseCookie name `fmap` getResponse+    rspCookie <- getResponseCookie name <$> getResponse     let ck = rspCookie `mplus` rqCookie-    let val = fmap cookieValue ck >>= decrypt key >>= return . decode-    let val' = val >>= either (const Nothing) Just-    case val' of+    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+          to <- checkTimeout timeout ts+          return $ case to of+            True -> Nothing+            False -> Just t   --------------------------------------------------------------------------------- | Inject the payload+-- | 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 key to val = do+setSecureCookie name domain key to val = do     t <- liftIO getCurrentTime+    val' <- encodeSecureCookie key (t, val)     let expire = to >>= Just . flip addUTCTime t . fromIntegral-    val' <- liftIO . encryptIO key . encode $ (t, val)-    let nc = Cookie name val' expire Nothing (Just "/") False True+    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.--- * Othwerwise, do a regular time-out check based on current time and given--- timestamp.+--+-- * 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 =-  let x' = fromIntegral x-  in do-      t1 <- liftIO getCurrentTime-      return $ t1 > addUTCTime x' t0+checkTimeout (Just x) t0 = do+    t1 <- liftIO getCurrentTime+    return $ t1 > addUTCTime (fromIntegral x) t0
src/Snap/Snaplet/Session/SessionManager.hs view
@@ -1,16 +1,30 @@ {-# 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           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.++-- | 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  
+ src/Snap/Snaplet/Test.hs view
@@ -0,0 +1,170 @@+-- | 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 after 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)
− src/Snap/Starter.hs 
@@ -1,129 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Main where---------------------------------------------------------------------------------import           Data.Char-import           Data.List-import qualified Data.ByteString.Char8 as S-import qualified Data.Text as T-import           Snap.Http.Server (snapServerVersion)-import           System.Directory-import           System.Environment-import           System.Exit-import           System.Console.GetOpt-import           System.FilePath---------------------------------------------------------------------------------import Snap.StarterTH------------------------------------------------------------------------------------ Creates a value tDir :: ([String], [(String, String)])-buildData "tDirBareBones" "barebones"-buildData "tDirDefault" "default"-buildData "tDirTutorial" "tutorial"---------------------------------------------------------------------------------usage :: String-usage = unlines-    [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter"-    , ""-    , "Usage:"-    , ""-    , "  snap <action>"-    , ""-    , "    <action> can be one of:"-    , "      init - create a new project directory structure in the " ++-        "current directory"-    , ""-    , "  Note: you can use --help after any of the above actions to get help "-    , "  on that action"-    ]----------------------------------------------------------------------------------initUsage :: String-initUsage = unlines-    [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter"-    , ""-    , "Usage:"-    , ""-    , "  snap init [type]"-    , ""-    , "    [type] can be one of:"-    , "      default   - A default project using snaplets and heist"-    , "      barebones - A barebones project with minimal dependencies"-    , "      tutorial  - The literate Haskell tutorial project"-    , ""-    , "  If [type] is omitted, the default project is generated."-    ]---printUsage :: [String] -> IO ()-printUsage ("init":_) = putStrLn initUsage-printUsage _ = putStrLn usage----------------------------------------------------------------------------------- Only one option for now-data Option = Help-  deriving (Show, Eq)---setup :: String -> ([FilePath], [(String, String)]) -> IO ()-setup projName tDir = do-    mapM createDirectory (fst tDir)-    mapM_ write (snd tDir)-  where-    write (f,c) =-        if isSuffixOf "foo.cabal" f-          then writeFile (projName ++ ".cabal") (insertProjName $ T.pack c)-          else writeFile f c-    isNameChar c = isAlphaNum c || c == '-'-    insertProjName c = T.unpack $ T.replace-                           (T.pack "projname")-                           (T.pack $ filter isNameChar projName) c---------------------------------------------------------------------------------initProject :: [String] -> IO ()-initProject args = do-    case getOpt Permute options args of-      (flags, other, [])-        | Help `elem` flags -> do printUsage other-                                  exitFailure-        | otherwise         -> go other-      (_, other, errs) -> do putStrLn $ concat errs-                             printUsage other-                             exitFailure--  where-    options =-        [ Option ['h'] ["help"]       (NoArg Help)-                 "Print this message"-        ]--    go ("init":rest) = init' rest-    go _ = do-        putStrLn "Error: Invalid action!"-        putStrLn usage-        exitFailure--    init' args' = do-        cur <- getCurrentDirectory-        let dirs = splitDirectories cur-            projName = last dirs-            setup' = setup projName-        case args' of-          []            -> setup' tDirDefault-          ["barebones"] -> setup' tDirBareBones-          ["default"]   -> setup' tDirDefault-          ["tutorial"]  -> setup' tDirTutorial-          _             -> do-            putStrLn initUsage-            exitFailure----------------------------------------------------------------------------------main :: IO ()-main = do-    args <- getArgs-    initProject args
− src/Snap/StarterTH.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Snap.StarterTH where---------------------------------------------------------------------------------import qualified Data.Foldable as F-import           Data.List-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import           System.Directory.Tree-import           System.FilePath------------------------------------------------------------------------------------------------------------------------------------------------------------------- Convenience types-type FileData = (String, String)-type DirData = FilePath------------------------------------------------------------------------------------ Gets all the directorys in a DirTree-getDirs :: [FilePath] -> DirTree a -> [FilePath]-getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) :-                           concatMap (getDirs (n:prefix)) c-getDirs _ (File _ _) = []-getDirs _ (Failed _ _) = []------------------------------------------------------------------------------------ Reads a directory and returns a tuple of the list of all directories--- encountered and a list of filenames and content strings.-readTree :: FilePath -> IO ([DirData], [FileData])-readTree dir = do-    d <- readDirectory $ dir </> "."-    let ps = zipPaths $ "" :/ (free d)-        fd = F.foldr (:) [] ps-        dirs = getDirs [] $ free d-    return (drop 1 dirs, fd)------------------------------------------------------------------------------------ Calls readTree and returns it's value in a quasiquote.-dirQ :: FilePath -> Q Exp-dirQ tplDir = do-    d <- runIO . readTree $ "project_template" </> tplDir-    lift d------------------------------------------------------------------------------------ Creates a declaration assigning the specified name the value returned by--- dirQ.-buildData :: String -> FilePath -> Q [Dec]-buildData dirName tplDir = do-    let dir = mkName dirName--    typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |]-    v <- valD (varP dir) (normalB $ dirQ tplDir) []-    return [typeSig, v]
+ test/bad.tpl view
@@ -0,0 +1,1 @@+<bad template
+ test/db.cfg view
@@ -0,0 +1,2 @@+dbServer = "localhost"+dbPort = 1234
+ test/devel.cfg view
@@ -0,0 +1,5 @@+topConfigField = "topConfigValue"++db {+import "db.cfg"+}
+ test/good.tpl view
@@ -0,0 +1,1 @@+Good template
− test/runTestsAndCoverage.sh 
@@ -1,62 +0,0 @@-#!/bin/sh--set -e--if [ -z "$DEBUG" ]; then-    export DEBUG=snap-testsuite-fi--SUITE=./dist/build/snap-testsuite/snap-testsuite--rm -f snap-testsuite.tix--if [ ! -f $SUITE ]; then-    cat <<EOF-Testsuite executable not found, please run:-    cabal configure-then-    cabal build-EOF-    exit;-fi--$SUITE $*--killall -HUP snap-testsuite--DIR=dist/hpc--rm -Rf $DIR-mkdir -p $DIR--EXCLUDES='Main-Blackbox.App-Blackbox.BarSnaplet-Blackbox.Common-Blackbox.EmbeddedSnaplet-Blackbox.FooSnaplet-Blackbox.Tests-Blackbox.Types-Snap.Snaplet.Internal.Lensed.Tests-Snap.Snaplet.Internal.LensT.Tests-Snap.Snaplet.Internal.RST.Tests-Snap.Snaplet.Internal.Tests-Snap.TestCommon-'--EXCL=""--for m in $EXCLUDES; do-    EXCL="$EXCL --exclude=$m"-done--rm -f non-cabal-appdir/templates/bad.tpl-rm -f non-cabal-appdir/templates/good.tpl-rm -fr non-cabal-appdir/snaplets/foosnaplet--hpc markup $EXCL --destdir=$DIR snap-testsuite >/dev/null 2>&1--cat <<EOF--Test coverage report written to $DIR.-EOF
− test/snap-testsuite.cabal 
@@ -1,166 +0,0 @@-name:           snap-testsuite-version:        0.0.1-build-type:     Simple-cabal-version:  >= 1.6--Executable snap-testsuite-  hs-source-dirs:  ../src suite-  main-is:         TestSuite.hs--  build-depends:-    Glob                       >= 0.5 && < 0.7,-    HUnit                      >= 1.2 && < 2,-    MonadCatchIO-transformers  >= 0.2 && < 0.3,-    QuickCheck                 >= 2.3.0.2,-    attoparsec                 >= 0.10 && <0.11,-    base                       >= 4 && < 5,-    bytestring                 >= 0.9 && < 0.10,-    containers                 >= 0.3,-    data-lens                  >= 2.0.1 && < 2.1,-    data-lens-template         >= 2.1.1 && < 2.2,-    directory,-    directory-tree             >= 0.10 && < 0.11,-    filepath,-    heist                      >= 0.7 && < 0.8,-    http-enumerator            >= 0.7.1.7 && < 0.8,-    mtl                        >= 2,-    process                    == 1.*,-    snap-core                  >= 0.7 && < 0.8,-    snap-server                >= 0.7 && < 0.8,-    test-framework             >= 0.4 && < 0.5,-    test-framework-hunit       >= 0.2.5 && < 0.3,-    test-framework-quickcheck2 >= 0.2.6 && < 0.3,-    text                       >= 0.11 && < 0.12,-    transformers               >= 0.2,-    unix                       >= 2.2.0.0 && < 2.6,-    utf8-string                >= 0.3   && < 0.4,-    template-haskell--- FIXME--  extensions:-    BangPatterns,-    CPP,-    DeriveDataTypeable,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses,-    NoMonomorphismRestriction,-    OverloadedStrings,-    PackageImports,-    Rank2Types,-    ScopedTypeVariables,-    TemplateHaskell,-    TypeFamilies,-    TypeOperators,-    TypeSynonymInstances--  ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded-               -fno-warn-unused-do-bind---Executable app-  hs-source-dirs:  ../src suite-  main-is:         AppMain.hs--  build-depends:-    MonadCatchIO-transformers  >= 0.2 && < 0.3,-    attoparsec                 >= 0.10 && <0.11,-    base                       >= 4 && < 5,-    bytestring                 >= 0.9 && < 0.10,-    cereal                     >= 0.3,-    clientsession              >= 0.7.3.6 && <0.8,-    configurator               >= 0.1 && < 0.3,-    containers                 >= 0.3,-    data-lens                  >= 2.0.1 && < 2.1,-    data-lens-template         >= 2.1.1 && < 2.2,-    directory,-    directory-tree             >= 0.10 && < 0.11,-    filepath,-    hashable                   >= 1.1,-    heist                      >= 0.7 && < 0.8,-    mtl                        >= 2,-    mwc-random                 >= 0.8,-    process                    == 1.*,-    snap-core                  >= 0.7 && < 0.8,-    snap-server                >= 0.7 && < 0.8,-    syb                        >= 0.1,-    time                       >= 1.1,-    text                       >= 0.11 && < 0.12,-    transformers               >= 0.2,-    unordered-containers       >= 0.1.4,-    utf8-string                >= 0.3   && < 0.4,-    template-haskell-    --FIXME--  extensions:-    BangPatterns,-    CPP,-    DeriveDataTypeable,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses,-    NoMonomorphismRestriction,-    OverloadedStrings,-    PackageImports,-    Rank2Types,-    ScopedTypeVariables,-    TemplateHaskell,-    TypeFamilies,-    TypeOperators,-    TypeSynonymInstances--  ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded-               -fno-warn-unused-do-bind--Executable nesttest-  hs-source-dirs:  ../src suite-  main-is:         NestTest.hs--  build-depends:-    MonadCatchIO-transformers  >= 0.2 && < 0.3,-    attoparsec                 >= 0.10 && <0.11,-    base                       >= 4 && < 5,-    bytestring                 >= 0.9 && < 0.10,-    containers                 >= 0.3,-    data-lens                  >= 2.0.1 && < 2.1,-    data-lens-template         >= 2.1 && < 2.2,-    directory,-    directory-tree             >= 0.10 && < 0.11,-    filepath,-    heist                      >= 0.7 && < 0.8,-    mtl                        >= 2,-    process                    == 1.*,-    snap-core                  >= 0.7 && < 0.8,-    snap-server                >= 0.7 && < 0.8,-    text                       >= 0.11 && < 0.12,-    transformers               >= 0.2,-    utf8-string                >= 0.3   && < 0.4,-    template-haskell-    --FIXME--  extensions:-    BangPatterns,-    CPP,-    DeriveDataTypeable,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses,-    NoMonomorphismRestriction,-    OverloadedStrings,-    PackageImports,-    Rank2Types,-    ScopedTypeVariables,-    TemplateHaskell,-    TypeFamilies,-    TypeOperators,-    TypeSynonymInstances--  ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded-               -fno-warn-unused-do-bind-
+ test/snaplets/baz/devel.cfg view
@@ -0,0 +1,2 @@+barSnapletField = "barValue"+
+ test/snaplets/baz/templates/bazconfig.tpl view
@@ -0,0 +1,1 @@+baz config page <appconfig/> <fooconfig/>
+ test/snaplets/baz/templates/bazpage.tpl view
@@ -0,0 +1,1 @@+baz template page <barsplice/>
+ test/snaplets/embedded/extra-templates/extra.tpl view
@@ -0,0 +1,1 @@+This is an extra template
+ test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl view
@@ -0,0 +1,1 @@+embedded snaplet page <asplice/>
+ test/snaplets/foosnaplet/devel.cfg view
@@ -0,0 +1,2 @@+fooSnapletField = "fooValue"+
+ test/snaplets/foosnaplet/templates/foopage.tpl view
@@ -0,0 +1,1 @@+foo template page
+ test/snaplets/heist/templates/_foopage.tpl view
@@ -0,0 +1,7 @@+<html>+  <head></head>+  <body>+    <p>An underscore template.</p>+    <someSplice/>+  </body>+</html>
+ test/snaplets/heist/templates/extraTemplates/barpage.tpl view
@@ -0,0 +1,4 @@+<html>+<head></head>+<body>Hi. Bar.</body>+</html>
+ test/snaplets/heist/templates/foopage.tpl view
@@ -0,0 +1,6 @@+<html>+  <head></head>+  <body>Hi.+    <aSplice/>+  </body>+</html>
+ test/snaplets/heist/templates/index.tpl view
@@ -0,0 +1,1 @@+index page
+ test/snaplets/heist/templates/page.tpl view
@@ -0,0 +1,8 @@+<html>+<head>+<title>Example App</title>+</head>+<body>+<apply-content/>+</body>+</html>
+ test/snaplets/heist/templates/session.tpl view
@@ -0,0 +1,1 @@+<session/>
+ test/snaplets/heist/templates/splicepage.tpl view
@@ -0,0 +1,1 @@+splice page <appsplice/>
+ test/snaplets/heist/templates/userpage.tpl view
@@ -0,0 +1,50 @@+<html>++  <head></head>++  <body>++    <userSplice>+      <h2>+	<ifLoggedIn>+	  <loggedInUser/> is logged in+	</ifLoggedIn>+	+	<ifLoggedOut>+	  You are not logged in+	</ifLoggedOut>+      </h2>++      <h3>loggedInUser: <loggedInUser/></h3>++      <p>UserID <userId/></p>++      <p>UserLogin <userLogin/></p>+      +      <p>UserEmail <userEmail/></p>++      <p>UserActive <userActive/></p>+      +      <p>UserLoginCount <userLoginCount/></p>+      +      <p>UserFailedCount <userFailedCount/></p>+      +      <p>UserLoginAt <userLoginAt/></p>+      +      <p>UserLastLoginAt <userLastLoginAt/></p>+      +      <p>UserSuspendedAt <userSuspendedAt/></p>+      +      <p>UserLoginIP <userLoginIP/></p>+      +      <p>UserLastLoginIP <userLastLoginIP/></p>+      +      <p>UserIfActive <userIfActive/></p>+      +      <p>userIfSuspended <userIfSuspended/></p>+      +    </userSplice>+    +  </body>+  +</html>
+ test/suite/Blackbox/Tests.hs view
@@ -0,0 +1,340 @@+{-# 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 <barsplice></barsplice>\n"+    , requestTest "bazpage2" "baz template page contents of the bar splice\n"+    , requestTest "bazpage3" "baz template page <barsplice></barsplice>\n"+    , requestTest "bazpage4" "baz template page <barsplice></barsplice>\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 <asplice></asplice>\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 = T.pack cwd'++        let prefix = T.intercalate "\n"+              [ "Error reloading site!"+              , ""+              , "Initializer threw an exception..."+              , T.concat+                [ cwd, "/snaplets/heist/templates/bad.tpl \""+                , cwd, "/snaplets/heist/templates/bad.tpl\" (line 2, column 1):"+                ]+              , "unexpected end of input"+              , "expecting \"=\", \"/\" or \">\""++              -- Building with the latest dependency versions produces the following:+              -- "CallStack (from HasCallStack):"+              -- "  error, called at src/Snap/Snaplet/Heist/Internal.hs:75:35 in main:Snap.Snaplet.Heist.Internal"+              ]++        let suffix = T.intercalate "\n"+              [ "...but before it died it generated the following output:"+              , "Initializing app @ /"+              , "Initializing heist @ /heist"+              , ""+              , ""+              ]++        let response = T.decodeUtf8 b++        assertEqual "admin/reload" prefix (T.take    (T.length prefix) response)+        assertEqual "admin/reload" suffix (T.takeEnd (T.length suffix) 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"++
+ test/suite/SafeCWD.hs view
@@ -0,0 +1,33 @@+module 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)
+ test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs view
@@ -0,0 +1,729 @@+{-# 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+
+ test/suite/Snap/Snaplet/Auth/SpliceTests.hs view
@@ -0,0 +1,68 @@+module 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
+ test/suite/Snap/Snaplet/Auth/Tests.hs view
@@ -0,0 +1,23 @@+{-# 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+    ]+
+ test/suite/Snap/Snaplet/Auth/Types/Tests.hs view
@@ -0,0 +1,178 @@+module 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"+
+ test/suite/Snap/Snaplet/Config/Tests.hs view
@@ -0,0 +1,102 @@+module 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
+ test/suite/Snap/Snaplet/Heist/Tests.hs view
@@ -0,0 +1,317 @@+{-# 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
+ test/suite/Snap/Snaplet/Internal/LensT/Tests.hs view
@@ -0,0 +1,121 @@+{-# 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++
+ test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs view
@@ -0,0 +1,125 @@+{-# 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
+ test/suite/Snap/Snaplet/Internal/RST/Tests.hs view
@@ -0,0 +1,67 @@+{-# 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)+
+ test/suite/Snap/Snaplet/Internal/Tests.hs view
@@ -0,0 +1,136 @@+{-# 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++
+ test/suite/Snap/Snaplet/Test/Common/App.hs view
@@ -0,0 +1,142 @@+{-# 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
+ test/suite/Snap/Snaplet/Test/Common/BarSnaplet.hs view
@@ -0,0 +1,57 @@+{-# 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+
+ test/suite/Snap/Snaplet/Test/Common/EmbeddedSnaplet.hs view
@@ -0,0 +1,60 @@+{-# 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)+
+ test/suite/Snap/Snaplet/Test/Common/FooSnaplet.hs view
@@ -0,0 +1,50 @@+{-# 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+
+ test/suite/Snap/Snaplet/Test/Common/Handlers.hs view
@@ -0,0 +1,60 @@+module 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
+ test/suite/Snap/Snaplet/Test/Common/Types.hs view
@@ -0,0 +1,29 @@+{-# 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
+ test/suite/Snap/Snaplet/Test/Tests.hs view
@@ -0,0 +1,123 @@+{-# 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
test/suite/Snap/TestCommon.hs view
@@ -1,112 +1,82 @@-{-# LANGUAGE ScopedTypeVariables #-}- module Snap.TestCommon where -import Control.Concurrent-import Control.Exception-import Control.Monad (forM_, when)-import Data.Maybe-import Data.Monoid-import Prelude hiding (catch)-import System.Cmd-import System.Directory-import System.Environment-import System.Exit-import System.FilePath-import System.FilePath.Glob-import System.Process hiding (cwd)+------------------------------------------------------------------------------+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 -import SafeCWD +------------------------------------------------------------------------------+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 -testGeneratedProject :: String  -- ^ project name and directory-                     -> String  -- ^ arguments to @snap init@-                     -> String  -- ^ arguments to @cabal install@-                     -> Int     -- ^ port to run http server on-                     -> IO ()   -- ^ action to run when the server goes up-                     -> IO ()-testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort-                     testAction = do-    cwd <- getCurrentDirectory-    let segments = reverse $ splitPath cwd-        projectPath = cwd </> "test-snap-exe" </> projName-        snapRoot = joinPath $ reverse $ drop 1 segments-        snapRepos = joinPath $ reverse $ drop 2 segments -        sandbox = cwd </> "test-cabal-dev"+------------------------------------------------------------------------------+showTestCase :: Show a => a -> Assertion+showTestCase a = assertBool "Show instance failed" $+                 ((showsPrec 5 a) "" == show a)+                 && (showList [a]) "" == "[" ++ show a ++ "]"+                  -        cabalDevArgs = "-s " ++ sandbox+------------------------------------------------------------------------------+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],"")]) -        args = cabalDevArgs ++ " " ++ cabalInstallArgs +                 +------------------------------------------------------------------------------+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 -        initialize = do-            snapExe <- findSnap-            systemOrDie $ snapExe ++ " init " ++ snapInitArgs -            snapCoreSrc   <- fromEnv "SNAP_CORE_SRC" $ snapRepos </> "snap-core"-            snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $ snapRepos </> "snap-server"-            xmlhtmlSrc    <- fromEnv "XMLHTML_SRC" $ snapRepos </> "xmlhtml"-            heistSrc      <- fromEnv "HEIST_SRC" $ snapRepos </> "heist"-            let snapSrc   =  snapRoot+------------------------------------------------------------------------------+eqTestCase :: (Eq a) => a -> a -> Assertion+eqTestCase a b = assertBool "Eq instance failed" $+                 if a == b+                 then (a /= b) == False+                 else (a /= b) == True -            forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap" ]-                  (pkgCleanUp sandbox) -            forM_ [ snapCoreSrc, snapServerSrc, xmlhtmlSrc, heistSrc-                  , snapSrc] $ \s ->-                systemOrDie $ "cabal-dev " ++ cabalDevArgs-                                ++ " add-source " ++ s+------------------------------------------------------------------------------+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) -            systemOrDie $ "cabal-dev install " ++ args-            let cmd = ("." </> "dist" </> "build" </> projName </> projName)-                      ++ " -p " ++ show httpPort-            putStrLn $ "Running \"" ++ cmd ++ "\""-            pHandle <- runCommand cmd-            waitABit-            return pHandle -        findSnap = do-            home <- fromEnv "HOME" "."-            p1 <- gimmeIfExists $ snapRoot </> "dist" </> "build" </> "snap" </> "snap"-            p2 <- gimmeIfExists $ home </> ".cabal" </> "bin" </> "snap"-            p3 <- findExecutable "snap"+------------------------------------------------------------------------------+handlerConfig :: Handler b v ()+handlerConfig = writeText =<< genericConfigString -            return $ fromMaybe (error "couldn't find snap executable")-                               (getFirst $ mconcat $ map First [p1,p2,p3]) -    putStrLn $ "Changing directory to "++projectPath-    inDir True projectPath $ bracket initialize cleanup (const testAction)-    removeDirectoryRecursiveSafe projectPath-  where--    fromEnv name def = do-        r <- getEnv name `catch` \(_::SomeException) -> return ""-        if r == "" then return def else return r--    cleanup pHandle = do-        terminateProcess pHandle-        waitForProcess pHandle--    waitABit = threadDelay $ 2*10^(6::Int)--    pkgCleanUp d pkg = do-        paths <- globDir1 (compile $ "packages*conf/" ++ pkg ++ "-*") d-        forM_ paths-              (\x -> (rm x `catch` \(_::SomeException) -> return ()))-      where-        rm x = do-            putStrLn $ "removing " ++ x-            removeFile x--    gimmeIfExists p = do-        b <- doesFileExist p-        if b then return (Just p) else return Nothing-+------------------------------------------------------------------------------+shConfigSplice :: SnapletLens (Snaplet b) v -> SnapletISplice b+shConfigSplice _lens = textSplice =<< lift (with' _lens genericConfigString) -systemOrDie :: String -> IO ()-systemOrDie s = do-    putStrLn $ "Running \"" ++ s ++ "\""-    system s >>= check-  where-    check ExitSuccess = return ()-    check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"
test/suite/TestSuite.hs view
@@ -1,54 +1,77 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Main where +------------------------------------------------------------------------------ import           Control.Concurrent-import           Control.Exception-import           Control.Monad-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Char8 as S-import qualified Network.HTTP.Enumerator as HTTP-import           Snap.Http.Server.Config-import           Snap.Snaplet-import           System.Posix.Process-import           System.Posix.Types---import           Test.Framework (defaultMain, Test)-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit hiding (Test, path)+import           Control.Exception                  (SomeException (..), bracket, catch, finally)+import           Control.Monad                      (void)+import           System.Directory                   (getCurrentDirectory, setCurrentDirectory)+import           System.FilePath                    ((</>))+import           System.IO -import           Snap.Http.Server (simpleHttpServe)-import           Blackbox.App+------------------------------------------------------------------------------ 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.TestCommon--import SafeCWD+import           Snap.Snaplet.Test.Common.App+import qualified Snap.Snaplet.Test.Tests+import           Test.Framework +import           SafeCWD  ------------------------------------------------------------------------------ main :: IO () main = do-    Blackbox.Tests.remove "non-cabal-appdir/templates/bad.tpl"-    Blackbox.Tests.remove "non-cabal-appdir/templates/good.tpl"-    Blackbox.Tests.removeDir "non-cabal-appdir/snaplets/foosnaplet"+    -- chdir into test/+    cwd <- getCurrentDirectory+    setCurrentDirectory (cwd </> "test") -    inDir False "non-cabal-appdir" startServer-    threadDelay $ 2*10^(6::Int)-    defaultMain tests+    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"+ -} -  where tests = [ internalServerTests-                , testDefault-                , testBarebones-                , testTutorial-                ]+--    (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@@ -57,58 +80,26 @@         , Snap.Snaplet.Internal.Tests.tests         ] -startServer :: IO ProcessID-startServer = forkProcess $ serve (setPort 9753 defaultConfig) app-  where-    serve config initializer = do-        (_, handler, doCleanup) <- runSnaplet initializer-        (conf, site)            <- combineConfig config handler-        _ <- try $ simpleHttpServe conf $ site-             :: IO (Either SomeException ())-        doCleanup +------------------------------------------------------------------------------+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) -testBarebones :: Test-testBarebones = testCase "snap/barebones" go   where-    go = testGeneratedProject "barebonesTest"-                              "barebones"-                              ""-                              port-                              testIt-    port = 9990-    testIt = do-        body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)-        assertEqual "server not up" "hello world" body---testDefault :: Test-testDefault = testCase "snap/default" go-  where-    go = testGeneratedProject "defaultTest"-                              ""-                              ""-                              port-                              testIt-    port = 9991-    testIt = do-        body <- liftM (S.concat . L.toChunks) $-                HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)-        assertBool "response contains phrase 'it works!'"-                   $ "It works!" `S.isInfixOf` body---testTutorial :: Test-testTutorial = testCase "snap/tutorial" go-  where-    go = testGeneratedProject "tutorialTest"-                              "tutorial"-                              ""-                              port-                              testIt-    port = 9992-    testIt = do-        body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)++"/hello"-        assertEqual "server not up" "hello world" body--+    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)