packages feed

snap 0.8.1 → 1.1.3.3

raw patch · 133 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.4,-    mtl >= 2 && < 3,-    snap-core   == 0.8.*,-    snap-server == 0.8.*--  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,24 +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 site--site :: Snap ()-site =-    ifTop (writeBS "hello world") <|>-    route [ ("foo", writeBS "bar")-          , ("echo/:echoparam", echoHandler)-          ] <|>-    dir "static" (serveDirectory ".")--echoHandler :: Snap ()-echoHandler = do-    param <- getParam "echoparam"-    maybe (writeBS "must specify echo/param in URL")-          writeBS param
− 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.11,-    data-lens-template >= 2.1 && < 2.2,-    heist >= 0.8 && < 0.9,-    MonadCatchIO-transformers >= 0.2.1 && < 0.4,-    mtl >= 2 && < 3,-    snap == 0.8.*,-    snap-core   == 0.8.*,-    snap-server == 0.8.*,-    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/snaplets/heist/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/snaplets/heist/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,30 +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-    }--makeLens ''App--instance HasHeist App where-    heistLens = subSnaplet heist----------------------------------------------------------------------------------type AppHandler = Handler App App--
− project_template/default/src/Main.hs 
@@ -1,100 +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-                                          ["snaplets/heist/templates"])--    _ <- try $ httpServe conf $ site :: IO (Either SomeException ())-    cleanup------------------------------------------------------------------------------------ | This action loads the config used by this application. The loaded config--- is returned as the first element of the tuple produced by the loadSnapTH--- Splice. The type is not solidly fixed, though it must be an IO action that--- produces the same type as 'getActions' takes. It also must be an instance of--- Typeable. If the type of this is changed, a full recompile will be needed to--- pick up the change, even in development mode.------ This action is only run once, regardless of whether development or--- production mode is in use.-getConf :: IO (Config Snap ())-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,90 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}----------------------------------------------------------------------------------- | This module is where all the routes and handlers are defined for your---   site. The 'app' function is the initializer that combines everything---   together and is exported by this module.----module Site-  ( app-  ) where---------------------------------------------------------------------------------import           Control.Applicative-import           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 "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 "templates"-    addRoutes routes-    return $ App h sTime--
− project_template/default/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/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.4,-    mtl >= 2 && < 3,-    snap        == 0.8.*,-    snap-core   == 0.8.*,-    snap-server == 0.8.*--  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,353 +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/*-          |-- *heist/*-              |-- templates/-          |-- subsnaplet1/-          |-- subsnaplet2/--Only the starred items are actually enforced by current code, but we want to-establish the others as a convention.  The file 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/snaplets/heist/templates/page.tpl--Now whenever your snaplet is used, its filesystem data will be automagically-copied into the local project that is using it, whenever the application is-run and it sees that the 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,221 +1,289 @@+cabal-version:  2.2 name:           snap-version:        0.8.1-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/static/screen.css,-  project_template/default/snaplets/heist/templates/echo.tpl,-  project_template/default/snaplets/heist/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/TestSuite.hs,-  test/suite/NestTest.hs,-  test/suite/Snap/TestCommon.hs,-  test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs,-  test/suite/Snap/Snaplet/Internal/RST/Tests.hs,-  test/suite/Snap/Snaplet/Internal/Tests.hs,-  test/suite/Snap/Snaplet/Internal/LensT/Tests.hs,-  test/suite/Blackbox/Types.hs,-  test/suite/Blackbox/FooSnaplet.hs,-  test/suite/Blackbox/BarSnaplet.hs,-  test/suite/Blackbox/Common.hs,-  test/suite/Blackbox/EmbeddedSnaplet.hs,-  test/suite/Blackbox/Tests.hs,-  test/suite/Blackbox/App.hs,-  test/suite/SafeCWD.hs,-  test/suite/AppMain.hs,-  test/non-cabal-appdir/db.cfg,-  test/non-cabal-appdir/bad.tpl,-  test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl,-  test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl,-  test/non-cabal-appdir/snaplets/baz/snaplet.cfg,-  test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl,-  test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl,-  test/non-cabal-appdir/snaplets/heist/templates/index.tpl,-  test/non-cabal-appdir/snaplets/heist/templates/session.tpl,-  test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl,-  test/non-cabal-appdir/snaplets/heist/templates/page.tpl,-  test/non-cabal-appdir/good.tpl,-  test/non-cabal-appdir/log/placeholder,-  test/non-cabal-appdir/snaplet.cfg,-  test/foosnaplet/templates/foopage.tpl,-  test/foosnaplet/snaplet.cfg+  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.Snaplet.Session.Common,+    Snap+    Snap.Snaplet+    Snap.Snaplet.Heist+    Snap.Snaplet.HeistNoClass+    Snap.Snaplet.Heist.Compiled+    Snap.Snaplet.Heist.Generic+    Snap.Snaplet.Heist.Interpreted+    Snap.Snaplet.Auth+    Snap.Snaplet.Auth.Backends.JsonFile+    Snap.Snaplet.Config+    Snap.Snaplet.Session+    Snap.Snaplet.Session.Common+    Snap.Snaplet.Session.SessionManager     Snap.Snaplet.Session.Backends.CookieSession+    Snap.Snaplet.Test    other-modules:-    Control.Access.RoleBased.Checker,-    Control.Access.RoleBased.Role,-    Control.Access.RoleBased.Types,-    Control.Access.RoleBased.Internal.Role,-    Control.Access.RoleBased.Internal.RoleMap,-    Control.Access.RoleBased.Internal.Rule,-    Control.Access.RoleBased.Internal.Types,-    Snap.Snaplet.Auth.AuthManager,-    Snap.Snaplet.Auth.Types,-    Snap.Snaplet.Auth.Handlers,-    Snap.Snaplet.Auth.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.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,-      old-time                >= 1.0     && < 1.2--  if !os(windows)-    build-depends:-      unix                    >= 2.2.0.0 && < 2.6+    Snap.Snaplet.Session.SecureCookie    build-depends:-    MonadCatchIO-transformers >= 0.2      && < 0.4,-    aeson                     >= 0.6      && < 0.7,-    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.11,-    data-lens-template        >= 2.1      && < 2.2,-    filepath                  >= 1.1      && < 1.4,-    hashable                  >= 1.1      && < 1.2,-    heist                     >= 0.7      && < 0.9,-    logict                    >= 0.4.2    && < 0.6,-    mtl                       >  2.0      && < 2.2,-    mwc-random                >= 0.8      && < 0.13,-    pwstore-fast              >= 2.2      && < 2.3,-    snap-core                 >= 0.8.1    && < 0.9,-    snap-server               >= 0.8.1    && < 0.9,-    stm                       >= 2.2      && < 2.4,-    syb                       >= 0.1      && < 0.4,-    template-haskell          >= 2.2      && < 2.8,-    text                      >= 0.11     && < 0.12,-    time                      >= 1.1      && < 1.5,-    transformers              >= 0.2      && < 0.4,+    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,-    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+    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.4,-    old-time            >= 1.0     && < 1.2,-    snap-server         >= 0.8     && < 0.9,-    template-haskell    >= 2.2     && < 2.8,-    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/Control/Access/RoleBased/Checker.hs 
@@ -1,224 +0,0 @@-{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE OverloadedStrings #-}--module Control.Access.RoleBased.Checker where---------------------------------------------------------------------------------import           Control.Monad-import           Control.Monad.Logic-import           Control.Monad.Reader-import           Control.Monad.State.Lazy-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.Maybe (fromMaybe, isJust)-import           Data.Text (Text)--------------------------------------------------------------------------------import           Control.Access.RoleBased.Internal.RoleMap (RoleMap)-import qualified Control.Access.RoleBased.Internal.RoleMap as RM-import           Control.Access.RoleBased.Internal.Types-import           Control.Access.RoleBased.Role----------------------------------------------------------------------------------type RoleBuilder a = StateT RoleMap RoleMonad a----------------------------------------------------------------------------------applyRule :: Role -> Rule -> [Role]-applyRule r (Rule _ f) = f r----------------------------------------------------------------------------------applyRuleSet :: Role -> RuleSet -> [Role]-applyRuleSet r (RuleSet m) = f r-  where-    f = fromMaybe (const []) $ M.lookup (_roleName r) m----------------------------------------------------------------------------------checkUnseen :: Role -> RoleBuilder ()-checkUnseen role = do-    m <- get-    if isJust $ RM.lookup role m then mzero else return ()----------------------------------------------------------------------------------checkSeen :: Role -> RoleBuilder ()-checkSeen = lnot . checkUnseen----------------------------------------------------------------------------------markSeen :: Role -> RoleBuilder ()-markSeen role = modify $ RM.insert role----------------------------------------------------------------------------------isum :: (MonadLogic m, MonadPlus m) => [m a] -> m a-isum l = case l of-            []     -> mzero-            (x:xs) -> x `interleave` isum xs------------------------------------------------------------------------------------ | Given a set of roles to check, and a set of implication rules describing--- how a given role inherits from other roles, this function produces a stream--- of expanded Roles. If a Role is seen twice, expandRoles mzeros.-expandRoles :: [Rule] -> [Role] -> RoleMonad Role-expandRoles rules roles0 = evalStateT (go roles0) RM.empty-  where-    ruleSet = rulesToSet rules--    go roles = isum $ map expandOne roles--    expandOne role = do-        checkUnseen role-        markSeen role-        return role `interleave` go newRoles--      where-        newRoles = applyRuleSet role ruleSet----------------------------------------------------------------------------------hasRole :: Role -> RuleChecker ()-hasRole r = RuleChecker $ do-    ch <- ask-    once $ go ch-  where-    go gen = do-        r' <- lift gen-        if r `matches` r' then return () else mzero----------------------------------------------------------------------------------missingRole :: Role -> RuleChecker ()-missingRole = lnot . hasRole----------------------------------------------------------------------------------hasAllRoles :: [Role] -> RuleChecker ()-hasAllRoles rs = RuleChecker $ do-    ch <- ask-    lift $ once $ go ch $ RM.fromList rs-  where-    go gen !st = do-        mr <- msplit gen-        maybe mzero-              (\(r,gen') -> let st' = RM.delete r st-                            in if RM.null st'-                                 then return ()-                                 else go gen' st')-              mr----------------------------------------------------------------------------------hasAnyRoles :: [Role] -> RuleChecker ()-hasAnyRoles rs = RuleChecker $ do-    ch <- ask-    lift $ once $ go ch-  where-    st = RM.fromList rs-    go gen = do-        mr <- msplit gen-        maybe mzero-              (\(r,gen') -> if isJust $ RM.lookup r st-                                 then return ()-                                 else go gen')-              mr----------------------------------------------------------------------------------runRuleChecker :: [Rule]-               -> [Role]-               -> RuleChecker a-               -> Bool-runRuleChecker rules roles (RuleChecker f) =-    case outs of-      []    -> False-      _     -> True-  where-    (RoleMonad st) = runReaderT f $ expandRoles rules roles-    outs = observeMany 1 st----------------------------------------------------------------------------------mkRule :: Text -> (Role -> [Role]) -> Rule-mkRule = Rule----------------------------------------------------------------------------------implies :: Role -> [Role] -> Rule-implies src dest = Rule (_roleName src)-                        (\role -> if role `matches` src then dest else [])----------------------------------------------------------------------------------impliesWith :: Role -> (HashMap Text RoleValue -> [Role]) -> Rule-impliesWith src f = Rule (_roleName src)-                         (\role -> if src `matches` role-                                     then f $ _roleData role-                                     else [])------------------------------------------------------------------------------------ Testing code follows: TODO: move into test suite---testRules :: [Rule]-testRules = [ "user" `implies` ["guest", "can_post"]-            , "superuser" `implies` [ "user"-                                    , "can_moderate"-                                    , "can_administrate"]-            , "superuser" `implies` [ addRoleData "arg" "*" "with_arg" ]-            , "with_arg" `impliesWith` \dat ->-                maybe [] (\arg -> [addRoleData "arg" arg "dependent_arg"]) $-                      M.lookup "arg" dat-            , "superuser" `implies` [ addRoleData "arg1" "a" $-                                      addRoleData "arg2" "b" "multi_args" ]-            ]--tX :: RuleChecker () -> Bool-tX f = runRuleChecker testRules ["superuser"] f--t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17 :: Bool-t1 = tX $ hasAnyRoles ["guest","userz"]--t2 = tX $ hasAllRoles ["guest","userz"]--t3 = tX $ hasAllRoles ["guest","user"]--t4 = tX $ hasRole "can_administrate"--t5 = tX $ hasRole "lkfdhjkjfhds"--t6 = tX $ do-         hasRole "guest"-         hasRole "superuser"--t7 = tX $ do-         hasRole "zzzzz"-         hasRole "superuser"--t8 = tX $ hasRole $ addRoleData "arg" "*" "dependent_arg"--t9 = tX $ hasRole "multi_args"--t10 = tX $ hasRole $ addRoleData "arg2" "b" "multi_args"--t11 = tX $ hasRole $ addRoleData "arg2" "z" "multi_args"--t12 = tX $ hasAllRoles [addRoleData "arg2" "b" "multi_args"]--t13 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"-                       , addRoleData "arg2" "b" "multi_args" ]--t14 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"-                       , addRoleData "arg2" "aaa" "multi_args" ]--t15 = tX $ missingRole "jflsdkjf"--t16 = tX $ do-          missingRole "fdjlksjlf"-          hasRole "multi_args"--t17 = tX $ missingRole "multi_args"
− src/Control/Access/RoleBased/Internal/Role.hs 
@@ -1,87 +0,0 @@-module Control.Access.RoleBased.Internal.Role where---------------------------------------------------------------------------------import           Control.Monad.ST-import           Data.Hashable-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.String-import           Data.Text (Text)-import qualified Data.Vector as V-import qualified Data.Vector.Algorithms.Merge as VA----------------------------------------------------------------------------------data RoleValue = RoleBool Bool-               | RoleText Text-               | RoleInt Int-               | RoleDouble Double-  deriving (Ord, Eq, Show)----------------------------------------------------------------------------------instance IsString RoleValue where-    fromString = RoleText . fromString----------------------------------------------------------------------------------instance Hashable RoleValue where-    hashWithSalt salt (RoleBool e)   = hashWithSalt salt e `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/Control/Access/RoleBased/Internal/RoleMap.hs 
@@ -1,60 +0,0 @@-module Control.Access.RoleBased.Internal.RoleMap where---------------------------------------------------------------------------------import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.HashSet (HashSet)-import qualified Data.HashSet as S-import           Data.List (find, foldl')-import           Data.Text (Text)--------------------------------------------------------------------------------import           Control.Access.RoleBased.Role-import           Control.Access.RoleBased.Internal.Types----------------------------------------------------------------------------------newtype RoleMap = RoleMap (HashMap Text (HashSet Role))----------------------------------------------------------------------------------fromList :: [Role] -> RoleMap-fromList = RoleMap . foldl' ins M.empty-  where-    ins m role =-        M.insertWith S.union (_roleName role) (S.singleton role) m----------------------------------------------------------------------------------lookup :: Role -> RoleMap -> Maybe Role-lookup role (RoleMap m) = find (`matches` role) l-  where-    l = maybe [] S.toList $ M.lookup (_roleName role) m----------------------------------------------------------------------------------delete :: Role -> RoleMap -> RoleMap-delete role (RoleMap m) = RoleMap $ maybe m upd $ M.lookup rNm m-  where-    rNm = _roleName role-    upd s = maybe m-                  (\r -> let s' = S.delete r s-                         in if S.null s'-                              then M.delete rNm m-                              else M.insert rNm s' m)-                  (find (`matches` role) $ S.toList s)----------------------------------------------------------------------------------insert :: Role -> RoleMap -> RoleMap-insert role (RoleMap m) =-    RoleMap $ M.insertWith S.union (_roleName role) (S.singleton role) m----------------------------------------------------------------------------------empty :: RoleMap-empty = RoleMap M.empty----------------------------------------------------------------------------------null :: RoleMap -> Bool-null (RoleMap m) = M.null m
− src/Control/Access/RoleBased/Internal/Rule.hs 
@@ -1,37 +0,0 @@-module Control.Access.RoleBased.Internal.Rule where---------------------------------------------------------------------------------import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.List (foldl')-import           Data.Monoid-import           Data.Text (Text)--------------------------------------------------------------------------------import           Control.Access.RoleBased.Internal.Role----------------------------------------------------------------------------------data Rule = Rule Text (Role -> [Role])----------------------------------------------------------------------------------newtype RuleSet = RuleSet (HashMap Text (Role -> [Role]))----------------------------------------------------------------------------------instance Monoid RuleSet where-    mempty = RuleSet M.empty-    (RuleSet m1) `mappend` (RuleSet m2) = RuleSet $ M.foldlWithKey' ins m2 m1-      where-        combine f1 f2 r = f1 r ++ f2 r-        ins m k v       = M.insertWith combine k v m----------------------------------------------------------------------------------ruleToSet :: Rule -> RuleSet-ruleToSet (Rule nm f) = RuleSet $ M.singleton nm f----------------------------------------------------------------------------------rulesToSet :: [Rule] -> RuleSet-rulesToSet = foldl' mappend (RuleSet M.empty) . map ruleToSet
− src/Control/Access/RoleBased/Internal/Types.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}--module Control.Access.RoleBased.Internal.Types-  ( module Control.Access.RoleBased.Internal.Role-  , module Control.Access.RoleBased.Internal.Rule-  , RoleMonad(..)-  , RuleChecker(..)-  ) where---------------------------------------------------------------------------------import           Control.Applicative-import           Control.Monad.Reader-import           Control.Monad.Logic--------------------------------------------------------------------------------import           Control.Access.RoleBased.Internal.Role-import           Control.Access.RoleBased.Internal.Rule------------------------------------------------------------------------------------ TODO: should the monads be transformers here? If they were, you could check--- more complex predicates here----------------------------------------------------------------------------------newtype RoleMonad a = RoleMonad { _unRC :: Logic a }-  deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic)----------------------------------------------------------------------------------newtype RuleChecker a = RuleChecker (ReaderT (RoleMonad Role) RoleMonad a)-  deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic)-
− src/Control/Access/RoleBased/Role.hs 
@@ -1,25 +0,0 @@-module Control.Access.RoleBased.Role where---------------------------------------------------------------------------------import qualified Data.HashMap.Strict as M-import           Control.Access.RoleBased.Internal.Types-import           Data.Text (Text)----------------------------------------------------------------------------------matches :: Role -> Role -> Bool-matches (Role a1 d1) (Role a2 d2) =-    a1 == a2 && dmatch (toSortedList d1) (toSortedList d2)-  where-    dmatch []         _      = True-    dmatch _          []     = False-    dmatch dds@(d:ds) (e:es) =-        case compare d e of-          LT -> False-          EQ -> dmatch ds es-          GT -> dmatch dds es----------------------------------------------------------------------------------addRoleData :: Text -> RoleValue -> Role -> Role-addRoleData k v (Role n d) = Role n $ M.insert k v d
− src/Control/Access/RoleBased/Types.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}--module Control.Access.RoleBased.Types-  ( Role(..)                    -- fixme: remove (..)-  , RoleValue(..)               -- fixme-  , RoleValueMeta(..)-  , RoleDataDefinition(..)-  , RoleMetadata(..)-  , Rule-  , RuleChecker-  ) where--import Control.Access.RoleBased.Internal.Types
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,213 +0,0 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE TemplateHaskell #-}----------------------------------------------------------------------------------- | 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 $-                   concat [ "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      = concat [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,140 +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,57 +0,0 @@-{-# LANGUAGE CPP #-}-module Snap.Loader.Devel.Signal (protectHandlers) where---------------------------------------------------------------------------------import Control.Exception (bracket)---#ifdef mingw32_HOST_OS--                                 --------------                                 -- windows ---                                 ---------------------------------------------------------------------------------------------import GHC.ConsoleHandler as C--saveHandlers :: IO C.Handler-saveHandlers = C.installHandler Ignore--restoreHandlers :: C.Handler -> IO C.Handler-restoreHandlers = C.installHandler----------------------------------------------------------------------------------#else--                                  ------------                                  -- posix ---                                  -------------------------------------------------------------------------------------------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--                                  -----------                                  -- both ---                                  ------------------------------------------------------------------------------------------protectHandlers :: IO a -> IO a-protectHandlers a = bracket saveHandlers restoreHandlers $ const a-------------------------------------------------------------------------------
− src/Snap/Loader/Devel/TreeWatcher.hs 
@@ -1,40 +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,27 +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,21 +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  @@ -135,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@@ -144,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@@ -200,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@@ -249,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'.   {-@@ -281,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 >@@ -291,7 +301,7 @@ >     , _companyName :: String >     } >-> makeLenses [''App]+> makeLenses ''App  The next thing we need to do is define an initializer. @@ -302,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
@@ -43,11 +43,10 @@   , UserId(..)   , Password(..)   , AuthFailure(..)-  , BackendError(..)   , Role(..)    -- * Other Utilities-  , authSettingsFromConfig +  , authSettingsFromConfig   , withBackend   , encryptPassword   , checkPassword@@ -61,9 +60,14 @@   , loginUser   , logoutUser   , requireUser+  , setPasswordResetToken+  , clearPasswordResetToken    -- * Splice helpers   , addAuthSplices+  , compiledAuthSplices+  , userCSplices+  , userISplices   , ifLoggedIn   , ifLoggedOut   , loggedInUser
src/Snap/Snaplet/Auth/AuthManager.hs view
@@ -20,7 +20,6 @@  ------------------------------------------------------------------------------ import           Data.ByteString (ByteString)-import           Data.Lens.Lazy import           Data.Text (Text) import           Data.Time import           Web.ClientSession@@ -33,12 +32,11 @@ ------------------------------------------------------------------------------ -- | 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+              -> IO (Either AuthFailure AuthUser) buildAuthUser r unm pass = do   now <- getCurrentTime   let au = defAuthUser {@@ -54,15 +52,14 @@ ------------------------------------------------------------------------------ -- | All storage backends need to implement this typeclass ----- Backend operations may throw 'BackendError's class IAuthBackend r where-  -- | Create or update the given 'AuthUser' record.  If the 'userId' in the-  -- 'AuthUser' already exists in the database, then that user's information-  -- should be updated.  If it does not exist, then a new user should be-  -- created.-  save                  :: r -> AuthUser -> IO AuthUser+  -- | 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 () @@ -73,7 +70,7 @@       backend               :: r         -- ^ Storage back-end -    , session               :: Lens b (Snaplet SessionManager)+    , session               :: SnapletLens b SessionManager         -- ^ A lens pointer to a SessionManager      , activeUser            :: Maybe AuthUser@@ -85,6 +82,9 @@     , rememberCookieName    :: ByteString         -- ^ Cookie name for the remember token +    , rememberCookieDomain  :: Maybe ByteString+        -- ^ Domain for which remember cookie will be created.+     , rememberPeriod        :: Maybe Int         -- ^ Remember period in seconds. Defaults to 2 weeks. @@ -102,6 +102,6 @@     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@@ -38,12 +43,12 @@ ------------------------------------------------------------------------------ -- | Initialize a JSON file backed 'AuthManager' initJsonFileAuthManager :: AuthSettings-                           -- ^ Authentication settings for your app-                        -> Lens b (Snaplet SessionManager)-                           -- ^ Lens into a 'SessionManager' auth snaplet will+                            -- ^ Authentication settings for your app+                        -> SnapletLens b SessionManager+                            -- ^ Lens into a 'SessionManager' auth snaplet will                            -- use                         -> FilePath-                           -- ^ Where to store user data as JSON+                            -- ^ Where to store user data as JSON                         -> SnapletInit b (AuthManager b) initJsonFileAuthManager s l db = do     makeSnaplet@@ -59,6 +64,7 @@                        , activeUser            = Nothing                        , minPasswdLen          = asMinPasswdLen s                        , rememberCookieName    = asRememberCookieName s+                       , rememberCookieDomain  = Nothing                        , rememberPeriod        = asRememberPeriod s                        , siteKey               = key                        , lockout               = asLockout s@@ -87,17 +93,25 @@ ------------------------------------------------------------------------------ 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  @@ -107,6 +121,7 @@ data UserCache = UserCache {     uidCache    :: UserIdCache          -- ^ the actual datastore   , loginCache  :: LoginUserCache       -- ^ fast lookup for login field+  , emailCache  :: EmailUserCache       -- ^ fast lookup for email field   , tokenCache  :: RemTokenUserCache    -- ^ fast lookup for remember tokens   , uidCounter  :: Int                  -- ^ user id counter }@@ -117,6 +132,7 @@ defUserCache = UserCache {     uidCache   = HM.empty   , loginCache = HM.empty+  , emailCache = HM.empty   , tokenCache = HM.empty   , uidCounter = 0 }@@ -149,7 +165,9 @@   -------------------------------------------------------------------------------jsonFileSave :: JsonFileAuthManager -> AuthUser -> IO AuthUser+jsonFileSave :: JsonFileAuthManager+             -> AuthUser+             -> IO (Either AuthFailure AuthUser) jsonFileSave mgr u = do     now        <- getCurrentTime     oldByLogin <- lookupByLogin mgr (userLogin u)@@ -169,17 +187,17 @@           return $! Right $! (cache', u')      case res of-      Left e             -> throw e+      Left _             -> return $! Left BackendError       Right (cache', u') -> do         dumpToDisk cache'-        return $! u'+        return $! Right u'    where     --------------------------------------------------------------------------     create :: UserCache            -> UTCTime            -> (Maybe AuthUser)-           -> STM (Either BackendError (UserCache, AuthUser))+           -> STM (Either AuthFailure (UserCache, AuthUser))     create cache now old = do       case old of         Just _  -> return $! Left DuplicateLogin@@ -190,6 +208,8 @@             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@@ -202,16 +222,17 @@     update :: UserCache            -> UTCTime            -> (Maybe AuthUser)-           -> STM (Either BackendError (UserCache, AuthUser))+           -> STM (Either AuthFailure (UserCache, AuthUser))     update cache now old =       case old of-        Nothing -> return $! Left $-                     BackendError "User not found; should never happen"+        Nothing -> return $! Left UserNotFound         Just x -> do           let oldLogin = userLogin x+          let oldEmail = userEmail x           let oldToken = userRememberToken x           let uid      = fromJust $ userId u           let newLogin = userLogin u+          let newEmail = userEmail u           let newToken = userRememberToken u            let lc       = if oldLogin /= userLogin u@@ -220,6 +241,16 @@                                 loginCache cache                            else loginCache cache +          let ec       = if oldEmail /= newEmail+                           then (case (oldEmail, newEmail) of+                                   (Nothing, Nothing) -> id+                                   (Just e,  Nothing) -> HM.delete e+                                   (Nothing, Just e ) -> HM.insert e uid+                                   (Just e,  Just e') -> HM.insert e' uid .+                                                         HM.delete e+                                ) (emailCache cache)+                           else emailCache cache+           let tc       = if oldToken /= newToken && isJust oldToken                            then HM.delete (fromJust oldToken) $ loginCache cache                            else tokenCache cache@@ -233,6 +264,7 @@           let new      = cache {                              uidCache   = HM.insert uid u' $ uidCache cache                            , loginCache = lc+                           , emailCache = ec                            , tokenCache = tc'                          } @@ -266,6 +298,16 @@       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@@ -299,6 +341,7 @@   toJSON uc = object     [ "uidCache"   .= uidCache   uc     , "loginCache" .= loginCache uc+    , "emailCache" .= emailCache uc     , "tokenCache" .= tokenCache uc     , "uidCounter" .= uidCounter uc     ]@@ -310,8 +353,8 @@     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"--
src/Snap/Snaplet/Auth/Handlers.hs view
@@ -11,17 +11,16 @@  ------------------------------------------------------------------------------ import           Control.Applicative-import           Control.Monad.CatchIO (throw)+import           Control.Monad (join, liftM, liftM2) import           Control.Monad.State-import           Control.Monad.Trans.Error import           Control.Monad.Trans.Maybe import           Data.ByteString (ByteString)-import           Data.Lens.Lazy-import           Data.Maybe (fromMaybe, 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@@ -39,12 +38,15 @@ ------------------------------------------------------------------------------ -- | 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)+           -> 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   ------------------------------------------------------------------------------@@ -59,28 +61,29 @@ ------------------------------------------------------------------------------ -- | Lookup a user by her username, check given password and perform login ---loginByUsername :: ByteString       -- ^ Username/login for user+loginByUsername :: Text             -- ^ 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 _ (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 rp+    withBackend $ loginByUsername' sk cn cd rp    where     --------------------------------------------------------------------------     loginByUsername' :: (IAuthBackend t) =>                         Key                      -> ByteString+                     -> Maybe ByteString                      -> Maybe Int                      -> t                      -> Handler b (AuthManager b) (Either AuthFailure AuthUser)-    loginByUsername' sk cn rp r =-        liftIO (lookupByLogin r $ decodeUtf8 unm) >>=+    loginByUsername' sk cn cd rp r =+        liftIO (lookupByLogin r unm) >>=         maybe (return $! Left UserNotFound) found        where@@ -94,7 +97,7 @@                   token <- gets randomNumberGenerator >>=                            liftIO . randomToken 64 -                  setRememberToken sk cn rp token+                  setRememberToken sk cn cd rp token                    let user' = user {                                 userRememberToken = Just (decodeUtf8 token)@@ -109,18 +112,21 @@ ------------------------------------------------------------------------------ -- | Remember user from the remember token if possible and perform login ---loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)+loginByRememberToken :: Handler b (AuthManager b) (Either AuthFailure AuthUser) loginByRememberToken = withBackend $ \impl -> do     key         <- gets siteKey     cookieName_ <- gets rememberCookieName     period      <- gets rememberPeriod -    runMaybeT $ do+    res <- runMaybeT $ do         token <- MaybeT $ getRememberToken key cookieName_ period-        user  <- MaybeT $ liftIO $ lookupByRememberToken impl-                                 $ decodeUtf8 token-        lift $ forceLogin user-        return user+        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   ------------------------------------------------------------------------------@@ -131,7 +137,8 @@     s <- gets session     withTop s $ withSession s removeSessionUserId     rc <- gets rememberCookieName-    forgetRememberToken rc+    rd <- gets rememberCookieDomain+    expireSecureCookie rc rd     modify $ \mgr -> mgr { activeUser = Nothing }  @@ -143,7 +150,7 @@     s   <- gets session     uid <- withTop s getSessionUserId     case uid of-      Nothing -> loginByRememberToken+      Nothing -> either (const Nothing) Just <$> loginByRememberToken       Just uid' -> liftIO $ lookupByUserId r uid'  @@ -157,17 +164,15 @@ ------------------------------------------------------------------------------ -- | 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 @@ -181,7 +186,8 @@ -- -- 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@@ -210,7 +216,8 @@ -- -- This will save the user to the backend. ---markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser+markAuthSuccess :: AuthUser+                -> Handler b (AuthManager b) (Either AuthFailure AuthUser) markAuthSuccess u = withBackend $ \r ->                         incLoginCtr u     >>=                         updateIp          >>=@@ -223,7 +230,7 @@      --------------------------------------------------------------------------     updateIp u' = do-        ip <- rqRemoteAddr <$> getRequest+        ip <- rqClientAddr <$> getRequest         return $ u' { userLastLoginIp = userCurrentLoginIp u'                     , userCurrentLoginIp = Just ip } @@ -267,6 +274,7 @@       Nothing -> auth u    where+    auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)     auth user =       case authenticatePassword user pw of         Just e -> do@@ -276,8 +284,7 @@         Nothing -> do           forceLogin user           modify (\mgr -> mgr { activeUser = Just user })-          user' <- markAuthSuccess user-          return $ Right user'+          markAuthSuccess user   ------------------------------------------------------------------------------@@ -287,14 +294,14 @@ -- who she says she is. -- forceLogin :: AuthUser       -- ^ An existing user, somehow looked up from db-           -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+           -> Handler b (AuthManager b) (Either AuthFailure ()) forceLogin u = do     s <- gets session-    withSession s $ do+    withSession s $         case userId u of           Just x -> do             withTop s (setSessionUserId x)-            return $ Right u+            return $ Right ()           Nothing -> return . Left $                      AuthError $ "forceLogin: Can't force the login of a user "                                    ++ "without userId"@@ -318,15 +325,11 @@ 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   ------------------------------------------------------------------------------@@ -348,7 +351,7 @@ getSessionUserId :: Handler b SessionManager (Maybe UserId) getSessionUserId = do   uid <- getFromSession "__user_id"-  return $ uid >>= return . UserId+  return $ liftM UserId uid   ------------------------------------------------------------------------------@@ -374,7 +377,7 @@ -- 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@@ -392,49 +395,66 @@ registerUser   :: ByteString            -- ^ Login field   -> ByteString            -- ^ Password field-  -> Handler b (AuthManager b) AuthUser+  -> Handler b (AuthManager b) (Either AuthFailure AuthUser) registerUser lf pf = do     l <- fmap decodeUtf8 <$> getParam lf     p <- getParam pf-    case liftM2 (,) l p of-      Nothing         -> throw PasswordMissing-      Just (lgn, pwd) -> createUser lgn pwd +    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-    runErrorT go >>= either loginFail (const loginSucc)+loginUser unf pwdf remf loginFail loginSucc =+    loginUser' unf pwdf remf >>= either loginFail (const loginSucc) -  where-    go = do-        mbUsername <- getParam unf-        mbPassword <- getParam pwdf-        remember   <- (runMaybeT $ do-                           field <- MaybeT $ return remf-                           value <- MaybeT $ getParam field-                           return $ value == "1"-                      ) >>= return . fromMaybe False +------------------------------------------------------------------------------+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") -        password <- maybe (throwError PasswordMissing) return mbPassword-        username <- maybe (fail "Username is missing") return mbUsername-        lift $ loginByUsername username (ClearText password) remember+    case mbUsername of+      Nothing -> return $ Left UsernameMissing+      Just u -> case mbPassword of+        Nothing -> return $ Left PasswordMissing+        Just p -> loginByUsername (decodeUtf8 u) (ClearText p) remember   ------------------------------------------------------------------------------@@ -452,12 +472,12 @@ -- 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"+requireUser :: SnapletLens b (AuthManager b)+                -- ^ Lens reference to an "AuthManager"             -> Handler b v a-               -- ^ Do this if no authenticated user is present.+                -- ^ Do this if no authenticated user is present.             -> Handler b v a-               -- ^ Do this if an authenticated user is present.+                -- ^ Do this if an authenticated user is present.             -> Handler b v a requireUser auth bad good = do     loggedIn <- withTop auth isLoggedIn@@ -478,5 +498,49 @@       -- ^ The function to run with the handler.   -> Handler b (AuthManager v) a withBackend f = join $ do-  (AuthManager backend_ _ _ _ _ _ _ _ _) <- get+  (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,72 +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)-  , ("loggedInUser", loggedInUser 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 :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v+loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b loggedInUser auth = do-  u <- liftHandler $ withTop auth currentUser-  liftHeist $ maybe (return []) (textSplice . userLogin) u +    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,16 +1,15 @@-{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE ExistentialQuantification  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE StandaloneDeriving         #-}  module Snap.Snaplet.Auth.Types where  -------------------------------------------------------------------------------import           Control.Applicative import           Control.Arrow-import           Control.Monad.CatchIO import           Control.Monad.Trans-import           Control.Monad.Trans.Error import           Crypto.PasswordStore import           Data.Aeson import           Data.ByteString       (ByteString)@@ -20,10 +19,15 @@ import           Data.Hashable         (Hashable) import           Data.Time import           Data.Text             (Text)+import           Data.Text.Encoding    (decodeUtf8, encodeUtf8) import           Data.Typeable import           Snap.Snaplet +#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif + ------------------------------------------------------------------------------ -- | Password is clear when supplied by the user and encrypted later when -- returned from the db.@@ -77,18 +81,30 @@ -- 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+data AuthFailure = AuthError String+                 | BackendError+                 | DuplicateLogin+                 | EncryptedPassword                  | IncorrectPassword-                 | PasswordMissing                  | LockedOut UTCTime    -- ^ Locked out until given time-                 | AuthError String-  deriving (Read, Show, Ord, Eq, Typeable)+                 | PasswordMissing+                 | UsernameMissing+                 | UserNotFound+  deriving (Read, Ord, Eq, Typeable) -instance Exception AuthFailure -instance Error AuthFailure where-    strMsg = AuthError+instance Show AuthFailure where+        show (AuthError s) = s+        show (BackendError) = "Failed to store data in the backend."+        show (DuplicateLogin) = "This login already exists in the backend."+        show (EncryptedPassword) = "Cannot login with encrypted password."+        show (IncorrectPassword) = "The password provided was not valid."+        show (LockedOut time) = "The login is locked out until " ++ show time+        show (PasswordMissing) = "No password provided."+        show (UsernameMissing) = "No username provided."+        show (UserNotFound) = "User not found in the backend." + ------------------------------------------------------------------------------ -- | Internal representation of a 'User'. By convention, we demand that the -- application is able to directly fetch a 'User' using this identifier.@@ -98,6 +114,10 @@ newtype UserId = UserId { unUid :: Text }   deriving ( Read, Show, Ord, Eq, FromJSON, ToJSON, Hashable ) +#if MIN_VERSION_aeson(1,0,0)+deriving instance FromJSONKey UserId+deriving instance ToJSONKey UserId+#endif  ------------------------------------------------------------------------------ -- | This will be replaced by a role-based permission system.@@ -110,6 +130,10 @@ data AuthUser = AuthUser     { userId               :: Maybe UserId     , userLogin            :: Text++    -- We have to have an email field for password reset functionality, but we+    -- don't want to force users to log in with their email address.+    , userEmail            :: Maybe Text     , userPassword         :: Maybe Password     , userActivatedAt      :: Maybe UTCTime     , userSuspendedAt      :: Maybe UTCTime@@ -123,6 +147,8 @@     , userLastLoginIp      :: Maybe ByteString     , userCreatedAt        :: Maybe UTCTime     , userUpdatedAt        :: Maybe UTCTime+    , userResetToken       :: Maybe Text+    , userResetRequestedAt :: Maybe UTCTime     , userRoles            :: [Role]     , userMeta             :: HashMap Text Value     }@@ -135,6 +161,7 @@ defAuthUser = AuthUser     { userId               = Nothing     , userLogin            = ""+    , userEmail            = Nothing     , userPassword         = Nothing     , userActivatedAt      = Nothing     , userSuspendedAt      = Nothing@@ -148,6 +175,8 @@     , userLastLoginIp      = Nothing     , userCreatedAt        = Nothing     , userUpdatedAt        = Nothing+    , userResetToken       = Nothing+    , userResetRequestedAt = Nothing     , userRoles            = []     , userMeta             = HM.empty     }@@ -163,23 +192,23 @@   --------------------------------------------------------------------------------- | Authetication settings defined at initialization time+-- | Authentication settings defined at initialization time data AuthSettings = AuthSettings {     asMinPasswdLen       :: Int-    -- ^ Currently not used/checked+      -- ^ Currently not used/checked    , asRememberCookieName :: ByteString-    -- ^ Name of the desired remember cookie+      -- ^ Name of the desired remember cookie    , asRememberPeriod     :: Maybe Int-    -- ^ How long to remember when the option is used in rest of the API.+      -- ^ 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])+      -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration])    , asSiteKey            :: FilePath-    -- ^ Location of app's encryption key+      -- ^ Location of app's encryption key }  @@ -230,14 +259,6 @@     return $ (pw . rc . rp . lo . sk) defAuthSettings  --------------------------------------------------------------------------------data BackendError = DuplicateLogin-                  | BackendError String-  deriving (Eq,Show,Read,Typeable)--instance Exception BackendError--                              --------------------                              -- JSON Instances --                              --------------------@@ -247,6 +268,7 @@   toJSON u = object     [ "uid"                .= userId                u     , "login"              .= userLogin             u+    , "email"              .= userEmail             u     , "pw"                 .= userPassword          u     , "activated_at"       .= userActivatedAt       u     , "suspended_at"       .= userSuspendedAt       u@@ -256,10 +278,12 @@     , "locked_until"       .= userLockedOutUntil    u     , "current_login_at"   .= userCurrentLoginAt    u     , "last_login_at"      .= userLastLoginAt       u-    , "current_ip"         .= userCurrentLoginIp    u-    , "last_ip"            .= userLastLoginIp       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     ]@@ -270,6 +294,7 @@   parseJSON (Object v) = AuthUser     <$> v .: "uid"     <*> v .: "login"+    <*> v .: "email"     <*> v .: "pw"     <*> v .: "activated_at"     <*> v .: "suspended_at"@@ -279,10 +304,12 @@     <*> v .: "locked_until"     <*> v .: "current_login_at"     <*> v .: "last_login_at"-    <*> v .: "current_ip"-    <*> v .: "last_ip"+    <*> 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"@@ -290,21 +317,21 @@  ------------------------------------------------------------------------------ instance ToJSON Password where-  toJSON (Encrypted x) = toJSON x+  toJSON (Encrypted x) = toJSON $ decodeUtf8 x   toJSON (ClearText _) =       error "ClearText passwords can't be serialized into JSON"   ------------------------------------------------------------------------------ instance FromJSON Password where-  parseJSON = fmap Encrypted . parseJSON+  parseJSON = fmap (Encrypted . encodeUtf8) . parseJSON   ------------------------------------------------------------------------------ instance ToJSON Role where-  toJSON (Role x) = toJSON x+  toJSON (Role x) = toJSON $ decodeUtf8 x   ------------------------------------------------------------------------------ instance FromJSON Role where-  parseJSON = fmap Role . parseJSON+  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
@@ -13,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@@ -32,27 +47,22 @@   -- * 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+import           Snap.Snaplet.HeistNoClass ( heistInit                                            , heistInit'                                            , clearHeistCache                                            )@@ -65,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@@ -89,10 +99,11 @@ -- 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-             -- ^ The url prefix for the template 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)   ------------------------------------------------------------------------------@@ -103,54 +114,150 @@ -- 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 HeistState modification.--- Without this function you wouldn't be able to bind more complicated splices--- like the cache tag.-modifyHeistTS :: (HasHeist b)-              => (HeistState (Handler b b) -> HeistState (Handler b b))-              -- ^ HeistState modifying function-              -> Initializer b v ()-modifyHeistTS = Unclassed.modifyHeistTS' heistLens+modifyHeistState :: (HasHeist b)+                 => (HeistState (Handler b b) -> HeistState (Handler b b))+                     -- ^ HeistState modifying function+                 -> Initializer b v ()+modifyHeistState = Unclassed.modifyHeistState' heistLens   ------------------------------------------------------------------------------ -- | Runs a function on with the Heist snaplet's 'HeistState'.-withHeistTS :: (HasHeist b)-            => (HeistState (Handler b b) -> a)-            -- ^ HeistState function to run-            -> Handler b v a-withHeistTS = Unclassed.withHeistTS' heistLens+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) @@ -160,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) @@ -189,9 +302,9 @@ -- 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 @@ -200,10 +313,10 @@ -- | Runs an action with additional splices bound into the Heist -- '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 @@ -216,22 +329,21 @@ -- > heistLocal (bindSplices mySplices) handlerThatNeedsSplices heistLocal :: HasHeist b            => (HeistState (Handler b b) -> HeistState (Handler b b))-           -- ^ HeistState modifying function+               -- ^ 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--- HeistState 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,63 +56,53 @@   , 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       :: HeistState (Handler b b)-    , _heistCTS      :: CacheTagState-    }----------------------------------------------------------------------------------changeTS :: (HeistState (Handler a a) -> HeistState (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   ------------------------------------------------------------------------------ -- | Clears data stored by the cache tag.  The cache tag automatically reloads -- its data when the specified TTL expires, but sometimes you may want to -- trigger a manual reload.  This function lets you do that.--- clearHeistCache :: Heist b -> IO () clearHeistCache = clearCacheTagState . _heistCTS @@ -98,262 +114,169 @@ ------------------------------------------------------------------------------ -- | 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)]-                   -> HeistState (Handler b b)-                   -> HeistState (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 --                           --------------------------- + ------------------------------------------------------------------------------ -- | The 'Initializer' for 'Heist'. This function is a convenience wrapper--- around `heistInit'` that uses the default `mempty` HeistState and sets up--- routes for all the templates.----heistInit :: FilePath                 -- ^ Path to templates+-- 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 templateDir = do-    makeSnaplet "heist" "" Nothing $ do-        hs <- heistInitWorker templateDir defaultHeistState-        addRoutes [ ("", heistServe) ]-        return hs+heistInit = gHeistInit heistServe   ------------------------------------------------------------------------------ -- | A lower level 'Initializer' for 'Heist'.  This initializer requires you--- to specify the initial HeistState.  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-           -> HeistState (Handler b b)-           -- ^ Initial HeistState+               -- ^ Path to templates+           -> HeistConfig (Handler b b)+               -- ^ Initial HeistConfig            -> SnapletInit b (Heist b)-heistInit' templateDir initialHeistState =-    makeSnaplet "heist" "" Nothing $-        heistInitWorker templateDir initialHeistState+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-                -> HeistState (Handler b b)-                -> Initializer b v (Heist b)-heistInitWorker templateDir initialHeistState = do-    (cacheFunc, cts) <- liftIO mkCacheTag-    let origTs = cacheFunc initialHeistState-    snapletPath <- getSnapletFilePath-    let tDir = snapletPath </> templateDir-    ts <- liftIO $ loadTemplates tDir origTs >>=-                   either error return-    printInfo $ T.pack $ unwords-        [ "...loaded"-        , (show $ length $ templateNames ts)-        , "templates from"-        , tDir-        ]--    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),()))   --------------------------------------------------------------------------------- | Adds templates to the Heist HeistState.  Other snaplets should use+-- | 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 :: ByteString-             -- ^ The url prefix for the template routes+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")   --------------------------------------------------------------------------------- | Adds templates to the Heist HeistState, and lets you specify where+-- | 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 :: ByteString-               -- ^ URL prefix for template routes+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 mempty-                   >>= either error return+addTemplatesAt h urlPrefix templateDir = do     rootUrl <- getSnapletRootURL-    let fullPrefix = U.toString rootUrl </> U.toString urlPrefix+    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"         , fullPrefix ++ "/"         ]-    addPostInitHook $ return . changeTS-        (`mappend` addTemplatePathPrefix (U.fromString fullPrefix) ts)+    let locations = [fmap addPrefix <$> loadTemplates templateDir]+        add (hc, dm) =+          ((over hcTemplateLocations (mappend locations) hc, dm), ())+    liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) add  +getCurHeistConfig :: Snaplet (Heist b)+                  -> Initializer b v (HeistConfig (Handler b b))+getCurHeistConfig h = case view snapletValue h of+    Configuring ref -> do+        (hc, _) <- liftIO $ readIORef ref+        return hc+    Running _ _ _ _ ->+        error "Can't get HeistConfig after heist is initialized."++ -------------------------------------------------------------------------------modifyHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))-               -> (HeistState (Handler b b) -> HeistState (Handler b b))-               -> Initializer b v ()-modifyHeistTS' heist f = do-    _lens <- getLens-    withTop' heist $ addPostInitHook $ return . changeTS f+getHeistState :: SnapletLens (Snaplet b) (Heist b)+              -> Handler b v (HeistState (Handler b b))+getHeistState heist = withTop' heist $ gets _heistState   -------------------------------------------------------------------------------modifyHeistTS :: (Lens b (Snaplet (Heist b)))-              -> (HeistState (Handler b b) -> HeistState (Handler b b))-              -> Initializer b v ()-modifyHeistTS heist f = modifyHeistTS' (subSnaplet heist) f+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 (Snaplet b) (Snaplet (Heist b)))-             -> (HeistState (Handler b b) -> a)-             -> Handler b v a-withHeistTS' heist f = withTop' heist $ gets (f . _heistTS)+modifyHeistState :: SnapletLens b (Heist b)+                 -> (HeistState (Handler b b) -> HeistState (Handler b b))+                 -> Initializer b v ()+modifyHeistState heist f = modifyHeistState' (subSnaplet heist) f   -------------------------------------------------------------------------------withHeistTS :: (Lens b (Snaplet (Heist b)))-            -> (HeistState (Handler b b) -> a)-            -> Handler b v a-withHeistTS heist f = withHeistTS' (subSnaplet heist) f+withHeistState' :: SnapletLens (Snaplet b) (Heist b)+                -> (HeistState (Handler b b) -> a)+                -> Handler b v a+withHeistState' heist f = do+    hs <- withTop' heist $ gets _heistState+    return $ f hs   -------------------------------------------------------------------------------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 b (Heist b)+               -> (HeistState (Handler b b) -> a)+               -> Handler b v a+withHeistState heist f = withHeistState' (subSnaplet heist) f   -------------------------------------------------------------------------------addSplices :: (Lens b (Snaplet (Heist b)))-           -> [(Text, SnapletSplice b v)]-           -> Initializer b v ()-addSplices heist splices = addSplices' (subSnaplet heist) splices+-- | 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), ())                               -----------------------@@ -362,12 +285,12 @@  ------------------------------------------------------------------------------ -- | 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@@ -375,49 +298,149 @@   ------------------------------------------------------------------------------+-- | 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)))+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)))+heistLocal :: SnapletLens b (Heist b)            -> (HeistState (Handler b b) -> HeistState (Handler b b))            -> Handler b v a            -> Handler b v a@@ -425,38 +448,35 @@   -------------------------------------------------------------------------------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@@ -151,10 +199,10 @@   where     doCopy srcRoot targetRoot filename = do         createDirectoryIfMissing True directory-        copyFile filename to+        copyFile filename toDir       where-        to = targetRoot </> makeRelative srcRoot filename-        directory = dropFileName to+        toDir = targetRoot </> makeRelative srcRoot filename+        directory = dropFileName toDir   ------------------------------------------------------------------------------@@ -174,32 +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 $ do-        modifyCfg $ modL scUserConfig (subconfig (T.pack sid))-        modifyCfg $ \c -> setL scFilePath+        modifyCfg $ over scUserConfig (subconfig (T.pack sid))+        modifyCfg $ \c -> set scFilePath           (_scFilePath c </> "snaplets" </> sid) c-    iModify (setL isTopLevel False)-    modifyCfg $ setL scDescription desc+    iModify (set isTopLevel False)+    modifyCfg $ set scDescription desc     cfg <- iGets _curConfig     printInfo $ T.pack $ concat       ["Initializing "@@ -209,10 +259,11 @@       ]      -- 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) -    let configLocation = _scFilePath cfg </> "snaplet.cfg"+    env <- iGets _environment+    let configLocation = _scFilePath cfg </> (env ++ ".cfg")     liftIO $ addToConfig [Optional configLocation]                          (_scUserConfig cfg)     mkSnaplet m@@ -221,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.@@ -235,7 +290,7 @@ bracketInit m = do     s <- iGet     res <- m-    iModify (setL curConfig (_curConfig s))+    iModify (set curConfig (_curConfig s))     return res  @@ -245,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:))   ------------------------------------------------------------------------------@@ -257,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 ""-    chroot rte (subSnaplet l . curLens) snaplet+    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  @@ -336,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   ------------------------------------------------------------------------------@@ -356,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@@ -364,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)   ------------------------------------------------------------------------------@@ -414,15 +489,18 @@ ------------------------------------------------------------------------------ -- | Builds an IO reload action for storage in the SnapletState. mkReloader :: FilePath-           -> MVar (Snaplet b)+           -> String+           -> ((Snaplet b -> Snaplet b) -> IO ())+           -> IORef (IO ())            -> Initializer b b (Snaplet b)            -> IO (Either Text Text)-mkReloader cwd mvar i = do-    !res <- runInitializer' mvar i cwd+mkReloader cwd env resetter cleanupRef i = do+    join $ readIORef cleanupRef+    !res <- runInitializer' resetter env i cwd     either (return . Left) good res   where     good (b,is) = do-        _ <- swapMVar mvar b+        _ <- resetter (const b)         msgs <- readIORef $ _initMessages is         return $ Right msgs @@ -439,34 +517,49 @@   ------------------------------------------------------------------------------+-- | 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 :: MVar (Snaplet b)+runInitializer :: ((Snaplet b -> Snaplet b) -> IO ())+               -> String                -> Initializer b b (Snaplet b)                -> IO (Either Text (Snaplet b, InitializerState b))-runInitializer mvar b = getCurrentDirectory >>= runInitializer' mvar b+runInitializer resetter env b =+    getCurrentDirectory >>= runInitializer' resetter env b   -------------------------------------------------------------------------------runInitializer' :: MVar (Snaplet b)+runInitializer' :: ((Snaplet b -> Snaplet b) -> IO ())+                -> String                 -> Initializer b b (Snaplet b)                 -> FilePath                 -> IO (Either Text (Snaplet b, InitializerState b))-runInitializer' mvar b@(Initializer i) cwd = do+runInitializer' resetter env b@(Initializer i) cwd = do+    cleanupRef <- newIORef (return ())+    let reloader_ = mkReloader cwd env resetter cleanupRef b     let builtinHandlers = [("/admin/reload", reloadSite)]-    let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing-                            (mkReloader cwd mvar b)+    let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing reloader_     logRef <- newIORef ""-    cleanupRef <- newIORef (return ())      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 $ Right (res', s)+            return $ (,s) <$> res'          handler e = do             join $ readIORef cleanupRef@@ -484,18 +577,23 @@   --------------------------------------------------------------------------------- | 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+-- | 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-    eRes <- runInitializer snapletMVar b+    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)+            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  @@ -516,20 +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     createDirectoryIfMissing False "log"-    let serve = simpleHttpServe conf+    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,34 +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           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.@@ -40,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.+        -- ^ 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   ------------------------------------------------------------------------------@@ -68,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   ------------------------------------------------------------------------------@@ -108,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) @@ -133,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@@ -141,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.@@ -192,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@@ -200,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@@ -241,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@@ -255,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   ------------------------------------------------------------------------------@@ -267,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@@ -284,14 +421,6 @@     good msg = do         writeText msg         writeText $ "Site successfully reloaded.\n"-    failIfNotLocal m = do-        -- FIXME: this moves to auth once control-panel is done-        rip <- liftM rqRemoteAddr getRequest-        if not $ elem rip [ "127.0.0.1"-                          , "localhost"-                          , "::1" ]-          then pass-          else m   ------------------------------------------------------------------------------@@ -325,25 +454,43 @@     { _isTopLevel      :: Bool     , _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   ------------------------------------------------------------------------------@@ -356,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@@ -370,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,6 +1,5 @@ module Snap.Snaplet.Session-  ( SessionManager(..)-  , ISessionManager(..)+  ( SessionManager   , withSession   , commitSession   , setInSession@@ -11,21 +10,21 @@   , resetSession   , touchSession +  -- * 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           Data.Text                           (Text) import           Snap.Core ------------------------------------------------------------------------------ import           Snap.Snaplet import           Snap.Snaplet.Session.Common import           Snap.Snaplet.Session.SecureCookie-import           Snap.Snaplet.Session.SessionManager-                   ( SessionManager(..), ISessionManager(..) )+import           Snap.Snaplet.Session.SessionManager +                   ( ISessionManager(..), SessionManager(..) ) import qualified Snap.Snaplet.Session.SessionManager as SM ------------------------------------------------------------------------------ @@ -33,7 +32,7 @@ ------------------------------------------------------------------------------ -- | 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
src/Snap/Snaplet/Session/Backends/CookieSession.hs view
@@ -1,28 +1,34 @@ -------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}  module Snap.Snaplet.Session.Backends.CookieSession-  ( initCookieSessionManager-  ) where+    ( initCookieSessionManager+    ) where  -------------------------------------------------------------------------------import           Control.Applicative 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           Snap.Core (Snap)+import           Data.ByteString                     (ByteString)+import           Data.Typeable+import           Data.HashMap.Strict                 (HashMap)+import qualified Data.HashMap.Strict                 as HM+import           Data.Serialize                      (Serialize)+import qualified Data.Serialize                      as S+import           Data.Text                           (Text)+import           Data.Text.Encoding+import           Snap.Core                           (Snap) import           Web.ClientSession++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif ------------------------------------------------------------------------------ import           Snap.Snaplet import           Snap.Snaplet.Session+import           Snap.Snaplet.Session.SessionManager+-------------------------------------------------------------------------------   ------------------------------------------------------------------------------@@ -43,15 +49,22 @@  ------------------------------------------------------------------------------ instance Serialize CookieSession where-    put (CookieSession a b) = S.put (a,b)-    get                     = uncurry CookieSession <$> 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 <$> S.get +encodeTuple :: (Text, Text) -> (ByteString, ByteString)+encodeTuple (a,b) = (encodeUtf8 a, encodeUtf8 b) ++decodeTuple :: (ByteString, ByteString) -> (Text, Text)+decodeTuple (a,b) = (decodeUtf8 a, decodeUtf8 b)++ ------------------------------------------------------------------------------ mkCookieSession :: RNG -> IO CookieSession mkCookieSession rng = do@@ -69,6 +82,10 @@         -- ^ 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.@@ -79,7 +96,7 @@  ------------------------------------------------------------------------------ loadDefSession :: CookieSessionManager -> IO CookieSessionManager-loadDefSession mgr@(CookieSessionManager ses _ _ _ rng) =+loadDefSession mgr@(CookieSessionManager ses _ _ _ _ rng) =     case ses of       Nothing -> do ses' <- mkCookieSession rng                     return $! mgr { session = Just ses' }@@ -100,22 +117,23 @@ initCookieSessionManager     :: FilePath             -- ^ Path to site-wide encryption key     -> ByteString           -- ^ Session cookie name+    -> Maybe ByteString     -- ^ Session cookie domain     -> Maybe Int            -- ^ Session time-out (replay attack protection)     -> SnapletInit b SessionManager-initCookieSessionManager fp cn to =+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 to rng+        return $! SessionManager $ CookieSessionManager Nothing key cn dom to rng   ------------------------------------------------------------------------------ instance ISessionManager CookieSessionManager where      ---------------------------------------------------------------------------    load mgr@(CookieSessionManager r _ _ _ _) =+    load mgr@(CookieSessionManager r _ _ _ _ _) =         case r of           Just _ -> return mgr           Nothing -> do@@ -129,7 +147,7 @@                   Right cs -> return $ mgr { session = Just cs }      ---------------------------------------------------------------------------    commit mgr@(CookieSessionManager r _ _ _ rng) = do+    commit mgr@(CookieSessionManager r _ _ _ _ rng) = do         pl <- case r of                 Just r' -> return . Payload $ S.encode r'                 Nothing -> liftIO (mkCookieSession rng) >>=@@ -145,25 +163,25 @@     touch = id      ---------------------------------------------------------------------------    insert k v mgr@(CookieSessionManager r _ _ _ _) = case r of+    insert k v mgr@(CookieSessionManager r _ _ _ _ _) = case r of         Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }         Nothing -> mgr      ---------------------------------------------------------------------------    lookup k (CookieSessionManager r _ _ _ _) = r >>= HM.lookup k . csSession+    lookup k (CookieSessionManager r _ _ _ _ _) = r >>= HM.lookup k . csSession      ---------------------------------------------------------------------------    delete k mgr@(CookieSessionManager r _ _ _ _) = case r of+    delete k mgr@(CookieSessionManager r _ _ _ _ _) = case r of         Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }         Nothing -> mgr      ---------------------------------------------------------------------------    csrf (CookieSessionManager r _ _ _ _) = case r of+    csrf (CookieSessionManager r _ _ _ _ _) = case r of         Just r' -> csCSRFToken r'         Nothing -> ""      ---------------------------------------------------------------------------    toList (CookieSessionManager r _ _ _ _) = case r of+    toList (CookieSessionManager r _ _ _ _ _) = case r of         Just r' -> HM.toList . csSession $ r'         Nothing -> [] @@ -183,5 +201,5 @@ ------------------------------------------------------------------------------ -- | 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,3 +1,4 @@+{-# LANGUAGE CPP               #-} ------------------------------------------------------------------------------ -- | This module contains functionality common among multiple back-ends. --@@ -11,11 +12,8 @@   ) where  -------------------------------------------------------------------------------import           Control.Applicative import           Control.Concurrent import           Control.Monad-import           Data.Serialize-import qualified Data.Serialize as S import           Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.Text.Encoding as T@@ -23,7 +21,11 @@ import           Numeric import           System.Random.MWC +#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif + ------------------------------------------------------------------------------ -- | High speed, mutable random number generator state newtype RNG = RNG (MVar GenIO)@@ -57,10 +59,3 @@ -- | Generate a randomized CSRF token mkCSRFToken :: RNG -> IO Text mkCSRFToken rng = T.decodeUtf8 <$> randomToken 40 rng----------------------------------------------------------------------------------instance Serialize Text where-    put = S.put . T.encodeUtf8-    get = T.decodeUtf8 <$> S.get-
src/Snap/Snaplet/Session/SecureCookie.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ -- | This is a support module meant to back all session back-end@@ -12,26 +13,30 @@ --     cookie. This will limit intercept-and-replay attacks by disallowing --     cookies older than the timeout threshold. -module Snap.Snaplet.Session.SecureCookie where---------------------------------------------------------------------------------import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Data.ByteString (ByteString)-import Data.Time-import Data.Time.Clock.POSIX-import Data.Serialize-import Snap.Core-import Web.ClientSession-+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.@@ -39,7 +44,7 @@   --------------------------------------------------------------------------------- Get the payload back+-- | Get the cookie payload. getSecureCookie :: (MonadSnap m, Serialize t)                 => ByteString       -- ^ Cookie name                 -> Key              -- ^ Encryption key@@ -49,9 +54,8 @@     rqCookie <- getCookie name     rspCookie <- getResponseCookie name <$> getResponse     let ck = rspCookie `mplus` rqCookie-    let val = fmap cookieValue ck >>= decrypt key >>= return . decode-    let val' = val >>= either (const Nothing) Just-    case val' of+    let val = fmap cookieValue ck >>= decodeSecureCookie key+    case val of       Nothing -> return Nothing       Just (ts, t) -> do           to <- checkTimeout timeout ts@@ -61,19 +65,55 @@   --------------------------------------------------------------------------------- | 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   ------------------------------------------------------------------------------
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,142 +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 -> 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,62 +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 directories in a DirTree----getDirs :: [FilePath] -> DirTree a -> [FilePath]-getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) :-                           concatMap (getDirs (n:prefix)) c-getDirs _ (File _ _) = []-getDirs _ (Failed _ _) = []------------------------------------------------------------------------------------ Reads a directory and returns a tuple of the list of all directories--- encountered and a list of filenames and content strings.----readTree :: FilePath -> IO ([DirData], [FileData])-readTree dir = do-    d <- readDirectory $ dir </> "."-    let ps = zipPaths $ "" :/ (free d)-        fd = F.foldr (:) [] ps-        dirs = getDirs [] $ free d-    return (drop 1 dirs, fd)------------------------------------------------------------------------------------ Calls readTree and returns its value in a quasiquote.----dirQ :: FilePath -> Q Exp-dirQ tplDir = do-    d <- runIO . readTree $ "project_template" </> tplDir-    lift d------------------------------------------------------------------------------------ Creates a declaration assigning the specified name the value returned by--- dirQ.----buildData :: String -> FilePath -> Q [Dec]-buildData dirName tplDir = do-    let dir  = mkName dirName-    typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |]-    v       <- valD (varP dir) (normalB $ dirQ tplDir) []--    return [typeSig, v]
+ 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/foosnaplet/snaplet.cfg 
@@ -1,2 +0,0 @@-fooSnapletField = "fooValue"-
− test/foosnaplet/templates/foopage.tpl 
@@ -1,1 +0,0 @@-foo template page
+ test/good.tpl view
@@ -0,0 +1,1 @@+Good template
− test/non-cabal-appdir/bad.tpl 
@@ -1,1 +0,0 @@-<bad template
− test/non-cabal-appdir/db.cfg 
@@ -1,3 +0,0 @@-dbServer = "localhost"-dbPort   = 1234-
− test/non-cabal-appdir/good.tpl 
@@ -1,1 +0,0 @@-Good template
− test/non-cabal-appdir/log/placeholder 
− test/non-cabal-appdir/snaplet.cfg 
@@ -1,6 +0,0 @@-topConfigField = "topConfigValue"--db  {-import "db.cfg"-}-
− test/non-cabal-appdir/snaplets/baz/snaplet.cfg 
@@ -1,2 +0,0 @@-barSnapletField = "barValue"-
− test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl 
@@ -1,1 +0,0 @@-baz config page <appconfig/> <fooconfig/>
− test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl 
@@ -1,1 +0,0 @@-baz template page <barsplice/>
− test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl 
@@ -1,1 +0,0 @@-This is an extra template
− test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl 
@@ -1,1 +0,0 @@-embedded snaplet page <asplice/>
− test/non-cabal-appdir/snaplets/heist/templates/index.tpl 
@@ -1,1 +0,0 @@-index page
− test/non-cabal-appdir/snaplets/heist/templates/page.tpl 
@@ -1,8 +0,0 @@-<html>-<head>-<title>Example App</title>-</head>-<body>-<content/>-</body>-</html>
− test/non-cabal-appdir/snaplets/heist/templates/session.tpl 
@@ -1,1 +0,0 @@-<session/>
− test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl 
@@ -1,1 +0,0 @@-splice page <appsplice/>
− test/runTestsAndCoverage.sh 
@@ -1,60 +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 $*--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/snaplets/heist/templates/bad.tpl-rm -f non-cabal-appdir/snaplets/heist/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,164 +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.8,-    HUnit                      >= 1.2     && < 2,-    MonadCatchIO-transformers  >= 0.2     && < 0.4,-    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.11,-    data-lens-template         >= 2.1.1   && < 2.2,-    directory,-    directory-tree             >= 0.10    && < 0.11,-    filepath,-    heist                      >= 0.7     && < 0.9,-    http-enumerator            >= 0.7.1.7 && < 0.8,-    mtl                        >= 2,-    process                    == 1.*,-    snap-core                  >= 0.8.1    && < 0.9,-    snap-server                >= 0.8.1    && < 0.9,-    test-framework             >= 0.6      && <0.7,-    test-framework-hunit       >= 0.2.7    && <0.3,-    test-framework-quickcheck2 >= 0.2.12.1 && <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--  extensions:-    BangPatterns,-    CPP,-    DeriveDataTypeable,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses,-    NoMonomorphismRestriction,-    OverloadedStrings,-    PackageImports,-    Rank2Types,-    ScopedTypeVariables,-    TemplateHaskell,-    TypeFamilies,-    TypeOperators,-    TypeSynonymInstances--  ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded-               -fno-warn-unused-do-bind---Executable app-  hs-source-dirs:  ../src suite-  main-is:         AppMain.hs--  build-depends:-    MonadCatchIO-transformers  >= 0.2     && < 0.4,-    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.11,-    data-lens-template         >= 2.1.1   && < 2.2,-    directory,-    directory-tree             >= 0.10    && < 0.11,-    filepath,-    hashable                   >= 1.1,-    heist                      >= 0.7     && < 0.9,-    mtl                        >= 2,-    mwc-random                 >= 0.8,-    process                    == 1.*,-    snap-core                  >= 0.8.1   && < 0.9,-    snap-server                >= 0.8.1   && < 0.9,-    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.4,-    attoparsec                 >= 0.10  && < 0.11,-    base                       >= 4     && < 5,-    bytestring                 >= 0.9   && < 0.10,-    containers                 >= 0.3,-    data-lens                  >= 2.0.1 && < 2.11,-    data-lens-template         >= 2.1   && < 2.2,-    directory,-    directory-tree             >= 0.10  && < 0.11,-    filepath,-    heist                      >= 0.7   && < 0.9,-    mtl                        >= 2,-    process                    == 1.*,-    snap-core                  >= 0.8.1 && < 0.9,-    snap-server                >= 0.8.1 && < 0.9,-    text                       >= 0.11  && < 0.12,-    transformers               >= 0.2,-    utf8-string                >= 0.3   && < 0.4,-    template-haskell--  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/AppMain.hs 
@@ -1,9 +0,0 @@-module Main where--import           Snap.Http.Server.Config-import           Snap.Snaplet--import           Blackbox.App--main :: IO ()-main = serveSnaplet defaultConfig app
− test/suite/Blackbox/App.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Blackbox.App where--import Prelude hiding (lookup)--import Control.Applicative-import Control.Monad.Trans-import Data.Lens.Lazy-import Data.Maybe-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Configurator-import Snap.Core-import Snap.Util.FileServe--import Snap.Snaplet-import Snap.Snaplet.Heist-import qualified Snap.Snaplet.HeistNoClass as HNC-import Text.Templating.Heist--import Blackbox.Common-import Blackbox.BarSnaplet-import Blackbox.FooSnaplet-import Blackbox.EmbeddedSnaplet-import Blackbox.Types-import Snap.Snaplet.Session hiding (lookup)-import Snap.Snaplet.Session.Backends.CookieSession---routeWithSplice :: Handler App App ()-routeWithSplice = do-    str <- with foo getFooField-    writeText $ T.pack $ "routeWithSplice: "++str--routeWithConfig :: Handler App App ()-routeWithConfig = do-    cfg <- getSnapletUserConfig-    val <- liftIO $ lookup cfg "topConfigField"-    writeText $ "routeWithConfig: " `T.append` fromJust val---sessionDemo :: Handler App App ()-sessionDemo = withSession session $ do-  with session $ do-    curVal <- getFromSession "foo"-    case curVal of-      Nothing -> do-        setInSession "foo" "bar"-      Just _ -> return ()-  list <- with session $ (T.pack . show) `fmap` sessionToList-  csrf <- with session $ (T.pack . show) `fmap` csrfToken-  HNC.renderWithSplices heist "session"-    [ ("session", liftHeist $ textSplice list)-    , ("csrf", liftHeist $ textSplice csrf) ]--sessionTest :: Handler App App ()-sessionTest = withSession session $ do-  q <- getParam "q"-  val <- case q of-    Just x -> do-      let x' = T.decodeUtf8 x-      with session $ setInSession "test" x'-      return x'-    Nothing -> maybe "" id `fmap` with session (getFromSession "test")-  writeText val--fooMod :: FooSnaplet -> FooSnaplet-fooMod f = f { fooField = fooField f ++ "z" }--app :: SnapletInit App App-app = makeSnaplet "app" "Test application" Nothing $ do-    hs <- nestSnaplet "heist" heist $ heistInit "templates"-    fs <- nestSnaplet "foo" foo fooInit-    bs <- nestSnaplet "" bar $ nameSnaplet "baz" $ barInit foo-    sm <- nestSnaplet "session" session $-          initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60))-    ns <- embedSnaplet "embed" embedded embeddedInit-    addSplices-        [("appsplice", liftHeist $ textSplice "contents of the app splice")]-    HNC.addSplices heist-        [("appconfig", shConfigSplice)]-    addRoutes [ ("/hello", writeText "hello world")-              , ("/routeWithSplice", routeWithSplice)-              , ("/routeWithConfig", routeWithConfig)-              , ("/public", serveDirectory "public")-              , ("/sessionDemo", sessionDemo)-              , ("/sessionTest", sessionTest)-              ]-    wrapHandlers (<|> heistServe)-    return $ App hs (modL snapletValue fooMod fs) bs sm ns---
− test/suite/Blackbox/BarSnaplet.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-module Blackbox.BarSnaplet where--import Prelude hiding (lookup)--import Control.Monad.State-import qualified Data.ByteString as B-import Data.Configurator-import Data.Lens.Lazy-import Data.Lens.Template-import Data.Maybe-import Data.Text (Text)-import Snap.Snaplet-import Snap.Snaplet.Heist-import Snap.Core-import Text.Templating.Heist--import Blackbox.Common-import Blackbox.FooSnaplet--data BarSnaplet b = BarSnaplet-    { _barField :: String-    , fooLens  :: Lens b (Snaplet FooSnaplet)-    }--makeLens ''BarSnaplet--barsplice :: [(Text, SnapletHeist b v Template)]-barsplice = [("barsplice", liftHeist $ textSplice "contents of the bar splice")]--barInit :: HasHeist b-        => Lens b (Snaplet FooSnaplet)-        -> SnapletInit b (BarSnaplet b)-barInit l = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do-    config <- getSnapletUserConfig-    addTemplates ""-    rootUrl <- getSnapletRootURL-    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)])-              ,("bazbadpage", heistServeSingle "cpyga")-              ,("bar/handlerConfig", handlerConfig)-              ]-    return $ BarSnaplet "bar snaplet data string" l-
− test/suite/Blackbox/Common.hs 
@@ -1,23 +0,0 @@-module Blackbox.Common where--import qualified Data.Text as T-import Snap.Core-import Snap.Snaplet-import Snap.Snaplet.Heist-import Text.Templating.Heist--genericConfigString :: (MonadSnaplet m, Monad (m b v)) => m b v T.Text-genericConfigString = do-    a <- getSnapletAncestry-    b <- getSnapletFilePath-    c <- getSnapletName-    d <- getSnapletDescription-    e <- getSnapletRootURL-    return $ T.pack $ show (a,b,c,d,e)--handlerConfig :: Handler b v ()-handlerConfig = writeText =<< genericConfigString--shConfigSplice :: SnapletSplice b v-shConfigSplice = liftHeist . textSplice =<< genericConfigString-
− test/suite/Blackbox/EmbeddedSnaplet.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Blackbox.EmbeddedSnaplet where--import Prelude hiding ((.))-import Control.Monad.State-import Data.Lens.Lazy-import Data.Lens.Template-import qualified Data.Text as T-import System.FilePath.Posix--import Snap.Snaplet-import Snap.Snaplet.Heist-import Text.Templating.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 "onemoredir" (snapletPath </> "extra-templates")--    embeddedLens <- getLens-    addRoutes [("aoeuhtns", withSplices-                    [("asplice", embeddedSplice embeddedLens)]-                    (render "embeddedpage"))-              ]-    return $ EmbeddedSnaplet hs 42---embeddedSplice :: (Lens (Snaplet b) (Snaplet EmbeddedSnaplet))-              -> SnapletHeist b v Template-embeddedSplice embeddedLens = do-    val <- liftWith embeddedLens $ gets _embeddedVal-    liftHeist $ textSplice $ T.pack $ "splice value" ++ (show val)-
− test/suite/Blackbox/FooSnaplet.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-module Blackbox.FooSnaplet where--import Prelude hiding (lookup)-import Control.Monad.State-import Data.Configurator-import Data.Maybe-import qualified Data.Text as T-import Snap.Snaplet-import Snap.Snaplet.Heist-import Snap.Core-import Text.Templating.Heist--import Blackbox.Common--data FooSnaplet = FooSnaplet { fooField :: String }--fooInit :: HasHeist b => SnapletInit b FooSnaplet-fooInit = makeSnaplet "foosnaplet" "A demonstration snaplet called foo."-    (Just $ return "../foosnaplet") $ do-    config <- getSnapletUserConfig-    addTemplates ""-    addSplices-        [("foosplice", liftHeist $ textSplice "contents of the foo splice")]-    rootUrl <- getSnapletRootURL-    fp <- getSnapletFilePath-    name <- getSnapletName-    addSplices [("fooconfig", shConfigSplice)]-    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/Blackbox/Tests.hs view
@@ -8,30 +8,94 @@   ) where  -------------------------------------------------------------------------------import           Control.Exception              (catch, throwIO)+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 qualified Network.HTTP.Enumerator        as HTTP+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)+------------------------------------------------------------------------------ + --------------------------------------------------------------------------------- TODO: fix all the hardcoded ports and strings in here, order the functions--- non-randomly+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@@ -39,30 +103,50 @@   -------------------------------------------------------------------------------assertRelativelyTheSame :: FilePath -> FilePath -> IO ()-assertRelativelyTheSame p expected = do-    b <- makeRelativeToCurrentDirectory p-    assertEqual ("expected " ++ expected) expected b+requestTest' :: String -> Text -> IO ()+requestTest' url desired = do+    actual <- get (S.pack $ testServerUrl ++ url) concatHandler+    assertEqual url desired (T.decodeUtf8 $ L.fromChunks [actual])   -------------------------------------------------------------------------------testServerUri :: String-testServerUri = "http://127.0.0.1:9753"+requestExpectingErrorPrefix :: String -> Int -> Text -> Test+requestExpectingErrorPrefix url status desired =+    testCase (testName url) $ requestExpectingErrorPrefix' url status desired   -------------------------------------------------------------------------------grab :: MonadIO m => String -> m L.ByteString-grab path = liftIO $ HTTP.simpleHttp $ testServerUri ++ path+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 "non-cabal-appdir/snaplets/foosnaplet"+    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@@ -81,7 +165,7 @@     f cwd b    where-    slashUri = "/" ++ uri+    slashUri = '/' : uri   ------------------------------------------------------------------------------@@ -89,7 +173,7 @@ fooHandlerConfigTest = testWithCwd "foo/handlerConfig" $ \cwd b -> do     let response = L.fromChunks [ "([\"app\"],\""                                 , S.pack cwd-                                , "/non-cabal-appdir/snaplets/foosnaplet\","+                                , "/snaplets/foosnaplet\","                                 , "Just \"foosnaplet\",\"A demonstration "                                 , "snaplet called foo.\",\"foo\")" ]     assertEqual "" response b@@ -100,7 +184,7 @@ barHandlerConfigTest = testWithCwd "bar/handlerConfig" $ \cwd b -> do     let response = L.fromChunks [ "([\"app\"],\""                                 , S.pack cwd-                                , "/non-cabal-appdir/snaplets/baz\","+                                , "/snaplets/baz\","                                 , "Just \"baz\",\"An example snaplet called "                                 , "bar.\",\"\")" ]     assertEqual "" response b@@ -112,10 +196,10 @@ bazpage5Test = testWithCwd "bazpage5" $ \cwd b -> do     let response = L.fromChunks [ "baz template page ([\"app\"],\""                                 , S.pack cwd-                                , "/non-cabal-appdir/snaplets/baz\","+                                , "/snaplets/baz\","                                 , "Just \"baz\",\"An example snaplet called "                                 , "bar.\",\"\")\n" ]-    assertEqual "" response b+    assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b)   ------------------------------------------------------------------------------@@ -127,29 +211,25 @@     let response = L.fromChunks [                      "baz config page ([],\""                    , S.pack cwd-                   , "/non-cabal-appdir\",Just \"app\","+                   , "\",Just \"app\"," -- TODO, right?                    , "\"Test application\",\"\") "                    , "([\"app\"],\""                    , S.pack cwd-                   , "/non-cabal-appdir/snaplets/foosnaplet\","+                   , "/snaplets/foosnaplet\","                    , "Just \"foosnaplet\",\"A demonstration snaplet "                    , "called foo.\",\"foo\")\n"                    ] -    assertEqual "" response b+    assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b)   ------------------------------------------------------------------------------ expect404 :: String -> IO ()-expect404 url = action `catch` h-  where-    action = do-        HTTP.simpleHttp $ "http://127.0.0.1:9753/" ++ url-        assertFailure "expected 404"--    h e@(HTTP.StatusCodeException c _) | c == 404  = return ()-                                       | otherwise = throwIO e-    h e                                            = throwIO e+expect404 url = do+    get (S.pack $ testServerUrl ++ url) $ \resp i -> do+        case getStatusCode resp of+          404 -> return ()+          _   -> assertFailure "expected 404"   ------------------------------------------------------------------------------@@ -157,66 +237,6 @@ request404Test url = testCase (testName url) $ expect404 url  --------------------------------------------------------------------------------requestTest' :: String -> Text -> IO ()-requestTest' url desired = do-    actual <- HTTP.simpleHttp $ "http://127.0.0.1:9753/" ++ url-    assertEqual url desired (T.decodeUtf8 actual)----------------------------------------------------------------------------------requestNoError :: String -> Text -> Test-requestNoError url desired =-    testCase (testName url) $ requestNoError' url desired----------------------------------------------------------------------------------requestNoError' :: String -> Text -> IO ()-requestNoError' url desired = do-    let fullUrl = "http://127.0.0.1:9753/" ++ url-    url' <- HTTP.parseUrl fullUrl-    HTTP.Response _ _ b <- liftIO $ HTTP.withManager $ HTTP.httpLbsRedirect url'-    assertEqual fullUrl desired (T.decodeUtf8 b)----------------------------------------------------------------------------------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"-    , requestNoError "bazbadpage" "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-    ]- remove :: FilePath -> IO () remove f = do     exists <- doesFileExist f@@ -226,84 +246,95 @@ removeDir :: FilePath -> IO () removeDir d = do     exists <- doesDirectoryExist d-    when exists $ removeDirectoryRecursive "non-cabal-appdir/snaplets/foosnaplet"+    when exists $ removeDirectoryRecursive "snaplets/foosnaplet"   ------------------------------------------------------------------------------ reloadTest :: Test reloadTest = testCase "internal/reload-test" $ do-    let goodTplOrig = "non-cabal-appdir" </> "good.tpl"-    let badTplOrig  = "non-cabal-appdir" </> "bad.tpl"-    let goodTplNew  = "non-cabal-appdir" </> "snaplets"  </> "heist"-                                         </> "templates" </> "good.tpl"-    let badTplNew   = "non-cabal-appdir" </> "snaplets"  </> "heist"-                                         </> "templates" </> "bad.tpl"+    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)+    assertBool "bad.tpl exists"  (not badExists)     expect404 "bad"      copyFile badTplOrig badTplNew     expect404 "good"     expect404 "bad" -    testWithCwd' "admin/reload" $ \cwd' b -> do-        let cwd = S.pack cwd'-        let response =-                L.fromChunks [ "Error reloading site!\n\nInitializer "-                             , "threw an exception...\n"-                             , cwd-                             , "/non-cabal-appdir/snaplets/heist"-                             , "/templates/bad.tpl \""-                             , cwd-                             , "/non-cabal-appdir/snaplets/heist/templates"-                             , "/bad.tpl\" (line 2, column 1):\nunexpected "-                             , "end of input\nexpecting \"=\", \"/\" or "-                             , "\">\"\n\n\n...but before it died it generated "-                             , "the following output:\nInitializing app @ /\n"-                             , "Initializing heist @ /heist\n\n" ]-        assertEqual "admin/reload" response b+    flip finally (remove badTplNew) $+      testWithCwd' "admin/reload" $ \cwd' b -> do+        let cwd = T.pack cwd' -    remove badTplNew+        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+    testWithCwd' "admin/reload" $ \cwd' b -> do  -- TODO/NOTE: Needs cleanup         let cwd = S.pack cwd'-        let response =-                L.fromChunks [ "Initializing app @ /\n"-                             , "Initializing heist @ /heist\n"-                             , "...loaded 5 templates from "-                             , cwd-                             , "/non-cabal-appdir/snaplets/heist/templates\n"-                             , "Initializing foosnaplet @ /foo\n"-                             , "...adding 1 templates from "-                             , cwd-                             , "/non-cabal-appdir/snaplets/foosnaplet"-                             , "/templates with route prefix foo/\n"-                             , "Initializing baz @ /\n"-                             , "...adding 2 templates from "-                             , cwd-                             , "/non-cabal-appdir/snaplets/baz/templates "-                             , "with route prefix /\n"-                             , "Initializing CookieSession @ /session\n"-                             , "Initializing embedded @ /\n"-                             , "Initializing heist @ /heist\n"-                             , "...loaded 1 templates from "-                             , cwd-                             , "/non-cabal-appdir/snaplets/embedded"-                             , "/snaplets/heist/templates\n"-                             , "...adding 1 templates from "-                             , cwd-                             , "/non-cabal-appdir/snaplets/embedded"-                             , "/extra-templates with route prefix "-                             , "onemoredir/\n"-                             , "Site successfully reloaded.\n"-                             ]+        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/Blackbox/Types.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Blackbox.Types where---import Data.Lens.Template--import Snap.Snaplet-import Snap.Snaplet.Heist--import Blackbox.FooSnaplet-import Blackbox.BarSnaplet-import Blackbox.EmbeddedSnaplet-import Snap.Snaplet.Session---data App = App-    { _heist :: Snaplet (Heist App)-    , _foo :: Snaplet FooSnaplet-    , _bar :: Snaplet (BarSnaplet App)-    , _session :: Snaplet SessionManager-    , _embedded :: Snaplet EmbeddedSnaplet-    }--makeLenses [''App]--instance HasHeist App where heistLens = subSnaplet heist-
− test/suite/NestTest.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Main where--import Prelude hiding ((.))-import Control.Monad.State-import Data.Lens.Lazy-import Data.Lens.Template-import qualified Data.Text as T-import           Snap.Http.Server.Config-import Snap.Core-import Snap.Util.FileServe--import Snap.Snaplet-import Snap.Snaplet.Heist-import Text.Templating.Heist---- If we universally quantify FooSnaplet to get rid of the type parameter--- mkLabels throws an error "Can't reify a GADT data constructor"-data FooSnaplet = FooSnaplet-    { _fooHeist :: Snaplet (Heist FooSnaplet)-    , _fooVal :: Int-    }--makeLenses [''FooSnaplet]--instance HasHeist FooSnaplet where-    heistLens = subSnaplet fooHeist--fooInit :: SnapletInit FooSnaplet FooSnaplet-fooInit = makeSnaplet "foosnaplet" "foo snaplet" Nothing $ do-    hs <- nestSnaplet "heist" fooHeist $ heistInit "templates"-    addTemplates "foo"-    rootUrl <- getSnapletRootURL-    fooLens <- getLens-    addRoutes [("fooRootUrl", writeBS rootUrl)-              ,("aoeuhtns", renderWithSplices "foo/foopage"-                    [("asplice", fooSplice fooLens)])-              ,("", heistServe)-              ]-    return $ FooSnaplet hs 42-----fooSplice :: (Lens (Snaplet b) (Snaplet (FooSnaplet b)))---          -> SnapletSplice (Handler b b)-fooSplice :: (Lens (Snaplet b) (Snaplet FooSnaplet))-          -> SnapletHeist b v Template-fooSplice fooLens = do-    val <- liftWith fooLens $ gets _fooVal-    liftHeist $ textSplice $ T.pack $ "splice value" ++ (show val)----------------------------------------------------------------------------------data App = App-    { _foo :: Snaplet (FooSnaplet)-    }--makeLenses [''App]--app :: SnapletInit App App-app = makeSnaplet "app" "nested snaplet application" Nothing $ do-    fs <- embedSnaplet "foo" foo fooInit-    addRoutes [ ("/hello", writeText "hello world")-              , ("/public", serveDirectory "public")-              ]-    return $ App fs--main :: IO ()-main = serveSnaplet defaultConfig app-
test/suite/SafeCWD.hs view
@@ -11,7 +11,9 @@  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@@ -25,6 +27,7 @@     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
@@ -2,11 +2,11 @@  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           Data.Lens.Template import           Prelude hiding (catch, (.)) import           Test.Framework import           Test.Framework.Providers.HUnit@@ -33,7 +33,9 @@       _bot0 :: Int } deriving (Show) -makeLenses [''TestType, ''TestSubType, ''TestBotType]+makeLenses ''TestType+makeLenses ''TestSubType+makeLenses ''TestBotType   ------------------------------------------------------------------------------@@ -54,10 +56,10 @@ testfmap :: Test testfmap = testCase "lensed/fmap" $ do --    x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState-    let x = fst $ runIdentity (runLensT (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 (bot . sub) defaultState)+    let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState)      assertEqual "fmap2" (12 :: Int) y     assertEqual "lens" (13 :: Int) $ _bot0 $ _bot $ _sub s'@@ -76,10 +78,10 @@ testApplicative :: Test testApplicative = testCase "lensed/applicative" $ do --    x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState-    let x = fst $ runIdentity (runLensT (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 (bot . sub) defaultState)+    let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState)      assertEqual "fmap2" (12::Int) y     assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'@@ -98,7 +100,7 @@ testMonadState :: Test testMonadState = testCase "lens/MonadState" $ do --    s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState-    let s = snd $ runIdentity (runLensT 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
test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs view
@@ -5,8 +5,8 @@ import           Control.Applicative import           Control.Category import           Control.Exception-import           Control.Monad.State.Strict-import           Data.Lens.Template+import           Control.Lens+import           Control.Monad.State.Lazy import           Prelude hiding (catch, (.)) import           Test.Framework import           Test.Framework.Providers.HUnit@@ -33,7 +33,9 @@       _bot0 :: Int } deriving (Show) -makeLenses [''TestType, ''TestSubType, ''TestBotType]+makeLenses ''TestType+makeLenses ''TestSubType+makeLenses ''TestBotType   ------------------------------------------------------------------------------@@ -52,10 +54,10 @@ ------------------------------------------------------------------------------ testfmap :: Test testfmap = testCase "lensed/fmap" $ do-    x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState+    x <- evalStateT (lensedAsState (fmap (*2) three) (sub . bot)) defaultState     assertEqual "fmap" 6 x -    (y,s') <- runStateT (lensedAsState twiddle (bot . sub)) defaultState+    (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState      assertEqual "fmap2" 12 y     assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'@@ -73,10 +75,10 @@ ------------------------------------------------------------------------------ testApplicative :: Test testApplicative = testCase "lensed/applicative" $ do-    x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState+    x <- evalStateT (lensedAsState (pure (*2) <*> three) (sub . bot)) defaultState     assertEqual "fmap" 6 x -    (y,s') <- runStateT (lensedAsState twiddle (bot . sub)) defaultState+    (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState      assertEqual "fmap2" (12::Int) y     assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'@@ -94,7 +96,7 @@ ------------------------------------------------------------------------------ testMonadState :: Test testMonadState = testCase "lens/MonadState" $ do-    s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState+    s <- execStateT (lensedAsState go (sub . bot . bot0)) defaultState      assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s     assertEqual "sub0" 3 $ _sub0 $ _sub s
test/suite/Snap/Snaplet/Internal/RST/Tests.hs view
@@ -16,7 +16,7 @@ import           Test.Framework.Providers.QuickCheck2 import           Test.HUnit hiding (Test, path) -import Snap.Snaplet.Internal.RST+import           Snap.Snaplet.Internal.RST   tests :: Test
test/suite/Snap/Snaplet/Internal/Tests.hs view
@@ -7,17 +7,18 @@   ( tests, initTest ) where  -------------------------------------------------------------------------------import           Control.Monad-import           Control.Monad.Trans-import           Data.ByteString (ByteString)-import           Data.Lens.Template-import           Data.List-import           Data.Text-import           Prelude hiding (catch, (.))-import           System.Directory-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit hiding (Test, path)+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@@ -39,7 +40,7 @@     , _bar :: Snaplet Bar     } -makeLens ''App+makeLenses ''App  --showConfig :: SnapletConfig -> IO () --showConfig c = do@@ -79,6 +80,9 @@      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@@ -108,7 +112,7 @@ ------------------------------------------------------------------------------ initTest :: IO () initTest = do-    (out,_,_) <- runSnaplet appInit+    (out,_,_) <- runSnaplet Nothing appInit      -- note from gdc: wtf?     if out == "aoeu"@@ -120,5 +124,13 @@ 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,143 +1,82 @@-{-# LANGUAGE ScopedTypeVariables #-}- module Snap.TestCommon where  -------------------------------------------------------------------------------import Control.Concurrent   ( threadDelay                )-import Control.Exception    ( ErrorCall(..)-                            , SomeException-                            , bracket-                            , catch-                            , throwIO-                            )-import Control.Monad        ( forM_                      )-import Data.Maybe           ( fromMaybe                  )-import Data.Monoid          ( First(..), mconcat         )-import Prelude       hiding ( catch                      )-import System.Cmd           ( system                     )-import System.Directory     ( doesFileExist-                            , getCurrentDirectory-                            , findExecutable-                            , removeFile-                            )-import System.Environment   ( getEnv                     )-import System.Exit          ( ExitCode(..)               )-import System.FilePath      ( joinPath, splitPath, (</>) )-import System.FilePath.Glob ( compile, globDir1          )-import System.Process       ( runCommand-                            , terminateProcess-                            , waitForProcess-                            )-+import           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 SafeCWD+import Snap.Core+import Snap.Snaplet+import Snap.Snaplet.Heist+import Heist.Interpreted   -------------------------------------------------------------------------------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+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 -    ---------------------------------------------------------------------------    let segments     = reverse $ splitPath cwd-        projectPath  = cwd </> "test-snap-exe" </> projName-        snapRoot     = joinPath $ reverse $ drop 1 segments-        snapRepos    = joinPath $ reverse $ drop 2 segments-        sandbox      = cwd </> "test-cabal-dev"-        cabalDevArgs = "-s " ++ sandbox-        args         = cabalDevArgs ++ " --reinstall " ++ cabalInstallArgs -        -----------------------------------------------------------------------        initialize = do-            snapExe <- findSnap-            systemOrDie $ snapExe ++ " init " ++ snapInitArgs--            snapCoreSrc   <- fromEnv "SNAP_CORE_SRC" $-                             snapRepos </> "snap-core"-            snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $-                             snapRepos </> "snap-server"-            xmlhtmlSrc    <- fromEnv "XMLHTML_SRC" $ snapRepos </> "xmlhtml"-            heistSrc      <- fromEnv "HEIST_SRC" $ snapRepos </> "heist"-            let snapSrc   =  snapRoot--            forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap" ]-                  (pkgCleanUp sandbox)--            forM_ [ snapCoreSrc, snapServerSrc, xmlhtmlSrc, heistSrc-                  , snapSrc] $ \s ->-                systemOrDie $ concat [ "cabal-dev "-                                     , cabalDevArgs-                                     , " add-source "-                                     , s-                                     ]--            systemOrDie $ "cabal-dev install " ++ args-            let cmd = ("." </> "dist" </> "build" </> projName </> projName)-                      ++ " -p " ++ show httpPort-            putStrLn $ "Running \"" ++ cmd ++ "\""-            pHandle <- runCommand cmd-            waitABit-            return pHandle--        -----------------------------------------------------------------------        findSnap = do-            home <- fromEnv "HOME" "."-            p1   <- gimmeIfExists $ snapRoot </> "dist" </> "build"-                                             </> "snap" </> "snap"-            p2   <- gimmeIfExists $ home </> ".cabal" </> "bin" </> "snap"-            p3   <- findExecutable "snap"--            return $ fromMaybe (error "couldn't find snap executable")-                               (getFirst $ mconcat $ map First [p1,p2,p3])+------------------------------------------------------------------------------+showTestCase :: Show a => a -> Assertion+showTestCase a = assertBool "Show instance failed" $+                 ((showsPrec 5 a) "" == show a)+                 && (showList [a]) "" == "[" ++ show a ++ "]"+                  -    ---------------------------------------------------------------------------    putStrLn $ "Changing directory to " ++ projectPath-    inDir True projectPath $ bracket initialize cleanup (const testAction)-    removeDirectoryRecursiveSafe projectPath+------------------------------------------------------------------------------+readTestCase :: (Eq a, Show a, Read a) => a -> Assertion+readTestCase a = assertBool "Read instance failed" $+                 ( ((readsPrec 1) (show a)) == ([(a,"")]))+                 && ((readList ("[" ++ show a ++ "]")) == [([a],"")])+                 && ((R.readPrec_to_S (R.readPrec) 5) (show a) == [(a,"")])+                 && ((R.readPrec_to_S (R.readListPrec) 5) ("[" ++ show a ++ "]")+                     == [([a],"")]) +                 +------------------------------------------------------------------------------+ordTestCase :: (Eq a, Ord a) => a -> a -> Assertion+ordTestCase a b = assertBool "Ord instance failed" $+                  low <= high+                  && (if   low /= high+                      then low < high  && compare low high == LT && high > low+                      else low == high && compare low high == EQ)   where-    ---------------------------------------------------------------------------    fromEnv name def = do-        r <- getEnv name `catch` \(_::SomeException) -> return ""-        if r == "" then return def else return r+    low  = min a b+    high = max a b -    ---------------------------------------------------------------------------    cleanup pHandle = do-        terminateProcess pHandle-        waitForProcess pHandle -    ---------------------------------------------------------------------------    waitABit = threadDelay $ 2*10^(6::Int)+------------------------------------------------------------------------------+eqTestCase :: (Eq a) => a -> a -> Assertion+eqTestCase a b = assertBool "Eq instance failed" $+                 if a == b+                 then (a /= b) == False+                 else (a /= b) == True -    ---------------------------------------------------------------------------    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+------------------------------------------------------------------------------+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) -    ---------------------------------------------------------------------------    gimmeIfExists p = do-        b <- doesFileExist p-        if b then return (Just p) else return Nothing +------------------------------------------------------------------------------+handlerConfig :: Handler b v ()+handlerConfig = writeText =<< genericConfigString + -------------------------------------------------------------------------------systemOrDie :: String -> IO ()-systemOrDie s = do-    putStrLn $ "Running \"" ++ s ++ "\""-    system s >>= check+shConfigSplice :: SnapletLens (Snaplet b) v -> SnapletISplice b+shConfigSplice _lens = textSplice =<< lift (with' _lens genericConfigString) -  where-    check ExitSuccess = return ()-    check _           = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"
test/suite/TestSuite.hs view
@@ -5,57 +5,69 @@  ------------------------------------------------------------------------------ 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           Prelude hiding (catch)-import           Snap.Http.Server.Config-import           Snap.Snaplet+import           Control.Exception                  (SomeException (..), bracket, catch, finally)+import           Control.Monad                      (void)+import           System.Directory                   (getCurrentDirectory, setCurrentDirectory)+import           System.FilePath                    ((</>)) import           System.IO-import           System.Posix.Process-import           System.Posix.Signals-import           System.Posix.Types-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit hiding (Test, path)+ -------------------------------------------------------------------------------import           Blackbox.App import qualified Blackbox.Tests-import           Snap.Http.Server (simpleHttpServe)+import           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           Snap.Snaplet.Test.Common.App+import qualified Snap.Snaplet.Test.Tests+import           Test.Framework  import           SafeCWD - ------------------------------------------------------------------------------ main :: IO () main = do+    -- chdir into test/+    cwd <- getCurrentDirectory+    setCurrentDirectory (cwd </> "test")+     Blackbox.Tests.remove-                "non-cabal-appdir/snaplets/heist/templates/bad.tpl"+                "snaplets/heist/templates/bad.tpl"     Blackbox.Tests.remove-                "non-cabal-appdir/snaplets/heist/templates/good.tpl"-    Blackbox.Tests.removeDir "non-cabal-appdir/snaplets/foosnaplet"+                "snaplets/heist/templates/good.tpl"+ {- Why were we removing this?+    Blackbox.Tests.removeDir "snaplets/foosnaplet"+ -} -    (tid, mvar) <- inDir False "non-cabal-appdir" startServer-    defaultMain [tests] `finally` killThread tid+--    (tid, mvar) <- inDir False "non-cabal-appdir" startServer+    (tid, mvar) <- inDir False "." startServer -    putStrLn "waiting for termination mvar"-    takeMVar mvar+    defaultMain [tests]+      `finally` do+          setCurrentDirectory cwd+          killThread tid+          putStrLn "waiting for termination mvar"+          takeMVar mvar -  where tests = mutuallyExclusive $+      where tests = mutuallyExclusive $                 testGroup "snap" [ internalServerTests-                                 , testDefault-                                 , testBarebones-                                 , testTutorial+                                 , 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 =@@ -73,71 +85,21 @@ startServer :: IO (ThreadId, MVar ()) startServer = do     mvar <- newEmptyMVar-    t    <- forkIO $ serve mvar (setPort 9753 defaultConfig) app+    t    <- forkIOWithUnmask $ \restore ->+            serve restore mvar (setPort 9753 .+                                setBind "127.0.0.1" $ defaultConfig) appInit     threadDelay $ 2*10^(6::Int)     return (t, mvar)    where-    serve mvar config initializer =+    gobble m = void m `catch` \(_::SomeException) -> return ()+    serve restore mvar config initializer =         flip finally (putMVar mvar ()) $-        handle handleErr $ do+        gobble $ restore $ do             hPutStrLn stderr "initializing snaplet"-            (_, handler, doCleanup) <- runSnaplet initializer--            flip finally doCleanup $ do-                (conf, site) <- combineConfig config handler-                hPutStrLn stderr "bringing up server"-                simpleHttpServe conf site-                hPutStrLn stderr "server killed"--    handleErr :: SomeException -> IO ()-    handleErr e = hPutStrLn stderr $ "startServer exception: " ++ show e----------------------------------------------------------------------------------testBarebones :: Test-testBarebones = testCase "snap/barebones" go-  where-    go = testGeneratedProject "barebonesTest"-                              "barebones"-                              ""-                              port-                              testIt-    port = 9990 :: Int-    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 :: Int-    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 :: Int-    testIt = do-        body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)++"/hello"-        assertEqual "server not up" "hello world" body--+            bracket (runSnaplet Nothing initializer)+                    (\(_, _, doCleanup) -> doCleanup)+                    (\(_, handler, _  ) -> do+                         (conf, site) <- combineConfig config handler+                         hPutStrLn stderr "bringing up server"+                         simpleHttpServe conf site)