packages feed

snap 0.4.3 → 1.1.3.3

raw patch · 100 files changed

Files

+ .ghci view
@@ -0,0 +1,2 @@+:set -XOverloadedStrings+:set -isrc
CONTRIBUTORS view
@@ -1,8 +1,7 @@ Ozgun Ataman <ozataman@gmail.com> Doug Beardsley <mightybyte@gmail.com> Gregory Collins <greg@gregorycollins.net>-Shu-yu Guo <shu@rfrn.org> Carl Howells <chowells79@gmail.com>-Shane O'Brien <shane@duairc.com>-James Sanders <jimmyjazz14@gmail.com>-Jacob Stanley <jystic@jystic.com>+Chris Smith <cdsmith@gmail.com>+Jurriën Stutterheim <j.stutterheim@me.com>+Alfredo Di Napoli <alfredo.dinapoli@gmail.com>
README.SNAP.md view
@@ -16,11 +16,11 @@    * a sensible and clean monad for web programming -  * an xml-based templating system for generating HTML based on-    [expat](http://expat.sourceforge.net/) (via-    [hexpat](http://hackage.haskell.org/package/hexpat)) that allows you to-    bind Haskell functionality to XML tags without getting PHP-style tag soup-    all over your pants+  * an xml-based templating system for generating HTML that allows you to bind+    Haskell functionality to XML tags without getting PHP-style tag soup all+    over your pants++  * a "snaplet" system for building web sites from composable pieces.  Snap is currently only officially supported on Unix platforms; it has been tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows.
README.md view
@@ -1,62 +1,71 @@-Snap Framework+Snap Framework [![Hackage Status](https://img.shields.io/hackage/v/snap.svg)](https://hackage.haskell.org/package/snap) ============== -This is the first developer prerelease of the Snap Framework snap-tool.  For more information about Snap, read the `README.SNAP.md` or-visit the Snap project website at http://www.snapframework.com/.--Snap is a nascent web framework for Haskell, based on iteratee I/O (as-[popularized by Oleg-Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)).+[![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 the `snap` executable and supporting library, which contains:--  * a command-line utility for creating initial Snap applications+This is top-level project for the Snap Framework, which contains:    * a library allowing Snap applications to recompile actions on the     fly in development mode, with no performance loss in production     mode. +  * a "snaplet" API allowing web applications to be build from composable+    pieces. +The command-line utility `snap` for creating initial Snap applications used to+be a part of this package. As of version 1.0, the snap command-line utility is+no longer provided by this package.  It is now provided by the package+[`snap-templates`](https://github.com/snapframework/snap-templates).+ Building snap ============= -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 -The haddock documentation can be built using the supplied `haddock.sh` shell-script:--    ./haddock.sh+The haddock documentation can be built using 'cabal haddock'.  The docs get put in `dist/doc/html/`.   ## Building the testsuite -Snap is still in its very early stages, so most of the "action" (and a big-chunk of the code) right now is centred on the test suite. Snap aims for 100%-test coverage, and we're trying hard to stick to that.--To build the test suite, `cd` into the `test/` directory and run+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 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/foo.cabal 
@@ -1,29 +0,0 @@-Name:                projname-Version:             0.1-Synopsis:            Project Synopsis Here-Description:         Project Description Here-License:             AllRightsReserved-Author:              Author-Maintainer:          maintainer@example.com-Stability:           Experimental-Category:            Web-Build-type:          Simple-Cabal-version:       >=1.2--Executable projname-  hs-source-dirs: src-  main-is: Main.hs--  Build-depends:-    base >= 4 && < 5,-    bytestring >= 0.9.1 && < 0.10,-    MonadCatchIO-transformers >= 0.2.1 && < 0.3,-    mtl >= 2 && < 3,-    snap-core == 0.4.*,-    snap-server == 0.4.*--  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/src/Main.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where--import           Control.Applicative-import           Snap.Types-import           Snap.Util.FileServe-import           Snap.Http.Server--main :: IO ()-main = quickHttpServe $-    ifTop (writeBS "hello world") <|>-    route [ ("foo", writeBS "bar")-          , ("echo/:echoparam", echoHandler)-          ] <|>-    dir "static" (serveDirectory ".")--echoHandler :: Snap ()-echoHandler = do-    param <- getParam "echoparam"-    maybe (writeBS "must specify echo/param in URL")-          writeBS param
− project_template/default/foo.cabal 
@@ -1,52 +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,-    heist >= 0.5 && < 0.6,-    MonadCatchIO-transformers >= 0.2.1 && < 0.3,-    mtl >= 2 && < 3,-    snap == 0.4.*,-    snap-core == 0.4.*,-    snap-server == 0.4.*,-    text >= 0.11 && < 0.12,-    time >= 1.1 && < 1.3,-    xmlhtml == 0.1.*--  extensions: TypeSynonymInstances MultiParamTypeClasses--  if flag(development)-    cpp-options: -DDEVELOPMENT-    build-depends: hint >= 0.3.2 && < 0.4-    -- In development mode, speed is already going to suffer, so skip-    -- the fancy optimization flags.  Additionally, disable all-    -- warnings.  The hint library doesn't give an option to execute-    -- compiled code when there were also warnings, so disabling-    -- warnings allows quicker workflow.-    ghc-options: -threaded -w-  else-    if impl(ghc >= 6.12.0)-      ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2-                   -fno-warn-orphans -fno-warn-unused-do-bind-    else-      ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2-                   -fno-warn-orphans-
− project_template/default/log/access.log 
− project_template/default/log/error.log 
− project_template/default/resources/static/screen.css 
@@ -1,26 +0,0 @@-html {-   padding: 0;-   margin: 0;-   background-color: #ffffff;-   font-family: Verdana, Helvetica, sans-serif;-}-body {-   padding: 0;-   margin: 0;-}-a {-   text-decoration: underline;-}-a :hover {-   cursor: pointer;-   text-decoration: underline;-}-img {-   border: none;-}-#content {-   padding-left: 1em;-}-#info {-   font-size: 60%;-}
− project_template/default/resources/templates/echo.tpl 
@@ -1,13 +0,0 @@-<html>-  <head>-    <title>Echo Page</title>-  </head>-  <body>-    <div id="content">-      <h1>Is there an echo in here?</h1>-    </div>-    <p>You wanted me to say this?</p>-    <p>"<message/>"</p>-    <p><a href="/">Return</a></p>-  </body>-</html>
− project_template/default/resources/templates/index.tpl 
@@ -1,32 +0,0 @@-<html>-  <head>-    <title>Snap web server</title>-    <link rel="stylesheet" type="text/css" href="screen.css"/>-  </head>-  <body>-    <div id="content">-      <h1>It works!</h1>-      <p>-        This is a simple demo page served using-        <a href="http://snapframework.com/docs/tutorials/heist">Heist</a>-        and the <a href="http://snapframework.com/">Snap</a> web framework.-      </p>-      <p>-        Echo test:-        <a href="/echo/cats">cats</a>-        <a href="/echo/dogs">dogs</a>-        <a href="/echo/fish">fish</a>-      </p>-      <table id="info">-        <tr>-          <td>Config generated at:</td>-          <td><start-time/></td>-        </tr>-        <tr>-          <td>Page generated at:</td>-          <td><current-time/></td>-        </tr>-      </table>-    </div>-  </body>-</html>
− project_template/default/src/Application.hs 
@@ -1,58 +0,0 @@-{---This module defines our application's monad and any application-specific-information it requires.---}--module Application-  ( Application-  , applicationInitializer-  ) where--import           Snap.Extension-import           Snap.Extension.Heist.Impl-import           Snap.Extension.Timer.Impl------------------------------------------------------------------------------------ | 'Application' is our application's monad. It uses 'SnapExtend' from--- 'Snap.Extension' to provide us with an extended 'MonadSnap' making use of--- the Heist and Timer Snap extensions.-type Application = SnapExtend ApplicationState------------------------------------------------------------------------------------ | 'ApplicationState' is a record which contains the state needed by the Snap--- extensions we're using.  We're using Heist so we can easily render Heist--- templates, and Timer simply to illustrate the config loading differences--- between development and production modes.-data ApplicationState = ApplicationState-    { templateState :: HeistState Application-    , timerState    :: TimerState-    }----------------------------------------------------------------------------------instance HasHeistState Application ApplicationState where-    getHeistState     = templateState-    setHeistState s a = a { templateState = s }----------------------------------------------------------------------------------instance HasTimerState ApplicationState where-    getTimerState     = timerState-    setTimerState s a = a { timerState = s }------------------------------------------------------------------------------------ | The 'Initializer' for ApplicationState. For more on 'Initializer's, see--- the documentation from the snap package. Briefly, this is used to--- generate the 'ApplicationState' needed for our application and will--- automatically generate reload\/cleanup actions for us which we don't need--- to worry about.-applicationInitializer :: Initializer ApplicationState-applicationInitializer = do-    heist <- heistInitializer "resources/templates"-    timer <- timerInitializer-    return $ ApplicationState heist timer
− project_template/default/src/Main.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}--{-|--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.---}--module Main where--#ifdef DEVELOPMENT-import           Snap.Extension.Loader.Devel-import           Snap.Http.Server (quickHttpServe)-#else-import           Snap.Extension.Server-#endif--import           Application-import           Site--main :: IO ()-#ifdef DEVELOPMENT-main = do-    -- All source directories will be watched for updates-    -- automatically.  If any extra directories should be watched for-    -- updates, include them here.-    snap <- $(let extraWatcheDirs = ["resources/templates"]-              in loadSnapTH 'applicationInitializer 'site extraWatcheDirs)-    quickHttpServe snap-#else-main = quickHttpServe applicationInitializer site-#endif
− project_template/default/src/Site.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-|--This is where all the routes and handlers are defined for your site. The-'site' function combines everything together and is exported by this module.---}--module Site-  ( site-  ) where--import           Control.Applicative-import           Data.Maybe-import qualified Data.Text.Encoding as T-import           Snap.Extension.Heist-import           Snap.Extension.Timer-import           Snap.Util.FileServe-import           Snap.Types-import           Text.Templating.Heist--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 :: Application ()-index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index"-  where-    indexSplices =-        [ ("start-time",   startTimeSplice)-        , ("current-time", currentTimeSplice)-        ]------------------------------------------------------------------------------------ | Renders the echo page.-echo :: Application ()-echo = do-    message <- decodedParam "stuff"-    heistLocal (bindString "message" (T.decodeUtf8 message)) $ render "echo"-  where-    decodedParam p = fromMaybe "" <$> getParam p------------------------------------------------------------------------------------ | The main entry point handler.-site :: Application ()-site = route [ ("/",            index)-             , ("/echo/:stuff", echo)-             ]-       <|> serveDirectory "resources/static"
− project_template/default/src/Snap/Extension/Timer.hs 
@@ -1,53 +0,0 @@-{-|--'Snap.Extension.Timer' exports the 'MonadTimer' interface which allows you to-keep track of the time at which your application was started. The interface's-only operation is 'startTime'.--Two splices, 'startTimeSplice' and 'currentTimeSplice' are also provided, for-your convenience.--'Snap.Extension.Timer.Timer' contains the only implementation of this-interface and can be used to turn your application's monad into a-'MonadTimer'.--More than anything else, this is intended to serve as an example Snap-Extension to any developer wishing to write their own Snap Extension.---}--module Snap.Extension.Timer-  ( MonadTimer(..)-  , startTimeSplice-  , currentTimeSplice-  ) where--import           Control.Monad.Trans-import           Data.Time.Clock-import qualified Data.Text as T-import           Snap.Types-import           Text.Templating.Heist-import           Text.XmlHtml------------------------------------------------------------------------------------ | The 'MonadTimer' type class. Minimal complete definition: 'startTime'.-class MonadSnap m => MonadTimer m where-    -- | The time at which your application was last loaded.-    startTime :: m UTCTime------------------------------------------------------------------------------------ | For your convenience, a splice which shows the start time.-startTimeSplice :: MonadTimer m => Splice m-startTimeSplice = do-    time <- lift startTime-    return $ [TextNode $ T.pack $ show $ time]------------------------------------------------------------------------------------ | For your convenience, a splice which shows the current time.-currentTimeSplice :: MonadTimer m => Splice m-currentTimeSplice = do-    time <- lift $ liftIO getCurrentTime-    return $ [TextNode $ T.pack $ show $ time]
− project_template/default/src/Snap/Extension/Timer/Impl.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-|--'Snap.Extension.Timer.Impl' is an implementation of the 'MonadTimer'-interface defined in 'Snap.Extension.Timer'.--As always, to use, add 'TimerState' to your application's state, along with an-instance of 'HasTimerState' for your application's state, making sure to use a-'timerInitializer' in your application's 'Initializer', and then you're ready to go.--This implementation does not require that your application's monad implement-interfaces from any other Snap Extension.---}--module Snap.Extension.Timer.Impl-  ( TimerState-  , HasTimerState(..)-  , timerInitializer-  , module Snap.Extension.Timer-  ) where--import           Control.Monad.Reader-import           Data.Time.Clock-import           Snap.Extension-import           Snap.Extension.Timer-import           Snap.Types----------------------------------------------------------------------------------- | Your application's state must include a 'TimerState' in order for your--- application to be a 'MonadTimer'.-newtype TimerState = TimerState-    { _startTime :: UTCTime-    }------------------------------------------------------------------------------------ | For your application's monad to be a 'MonadTimer', your application's--- state needs to be an instance of 'HasTimerState'. Minimal complete--- definition: 'getTimerState', 'setTimerState'.-class HasTimerState s where-    getTimerState :: s -> TimerState-    setTimerState :: TimerState -> s -> s------------------------------------------------------------------------------------ | The Initializer for 'TimerState'. No arguments are required.-timerInitializer :: Initializer TimerState-timerInitializer = liftIO getCurrentTime >>= mkInitializer . TimerState----------------------------------------------------------------------------------instance InitializerState TimerState where-    extensionId = const "Timer/Timer"-    mkCleanup   = const $ return ()-    mkReload    = const $ return ()----------------------------------------------------------------------------------instance HasTimerState s => MonadTimer (SnapExtend s) where-    startTime = fmap _startTime $ asks getTimerState----------------------------------------------------------------------------------instance (MonadSnap m, HasTimerState s) => MonadTimer (ReaderT s m) where-    startTime = fmap _startTime $ asks getTimerState
+ 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,122 +1,290 @@+cabal-version:  2.2 name:           snap-version:        0.4.3-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:         James Sanders, Shu-yu Guo, Gregory Collins, Doug Beardsley+author:         Ozgun Ataman, Doug Beardsley,+                Gregory Collins, Carl Howells, Chris Smith maintainer:     snap@snapframework.com build-type:     Simple-cabal-version:  >= 1.6 homepage:       http://snapframework.com/-category:       Web+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/foo.cabal,-  project_template/barebones/src/Main.hs,-  project_template/default/foo.cabal,-  project_template/default/log/access.log,-  project_template/default/log/error.log,-  project_template/default/resources/static/screen.css,-  project_template/default/resources/templates/echo.tpl,-  project_template/default/resources/templates/index.tpl,-  project_template/default/src/Application.hs,-  project_template/default/src/Main.hs,-  project_template/default/src/Site.hs,-  project_template/default/src/Snap/Extension/Timer/Impl.hs,-  project_template/default/src/Snap/Extension/Timer.hs,+  changelog.md,+  design.md,   extra/hscolour.css,   extra/haddock.css,   extra/logo.gif,-  test/snap-testsuite.cabal,-  test/runTests.sh,-  test/suite/Snap/TestCommon.hs,-  test/suite/TestSuite.hs+  haddock.sh,+  runTestsAndCoverage.sh,+  test/bad.tpl,+  test/db.cfg,+  test/devel.cfg,+  test/good.tpl,+  test/snaplets/baz/devel.cfg,+  test/snaplets/baz/templates/bazconfig.tpl,+  test/snaplets/baz/templates/bazpage.tpl,+  test/snaplets/embedded/extra-templates/extra.tpl,+  test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl,+  test/snaplets/foosnaplet/devel.cfg,+  test/snaplets/foosnaplet/templates/foopage.tpl,+  test/snaplets/heist/templates/_foopage.tpl,+  test/snaplets/heist/templates/extraTemplates/barpage.tpl,+  test/snaplets/heist/templates/foopage.tpl,+  test/snaplets/heist/templates/index.tpl,+  test/snaplets/heist/templates/page.tpl,+  test/snaplets/heist/templates/session.tpl,+  test/snaplets/heist/templates/splicepage.tpl,+  test/snaplets/heist/templates/userpage.tpl +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.Extension.Heist,-    Snap.Extension.Heist.Impl,-    Snap.Extension.Loader.Devel,-    Snap.Extension.Server,-    Snap.Extension+    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:-    Snap.Extension.Loader.Devel.Evaluator,-    Snap.Extension.Loader.Devel.Signal,-    Snap.Extension.Loader.Devel.TreeWatcher+    Paths_snap+    Snap.Snaplet.Auth.AuthManager+    Snap.Snaplet.Auth.Types+    Snap.Snaplet.Auth.Handlers+    Snap.Snaplet.Auth.SpliceHelpers+    Snap.Snaplet.Heist.Internal+    Snap.Snaplet.Internal.Initializer+    Snap.Snaplet.Internal.LensT+    Snap.Snaplet.Internal.Lensed+    Snap.Snaplet.Internal.RST+    Snap.Snaplet.Internal.Types+    Snap.Snaplet.Session.SecureCookie    build-depends:-    base >= 4 && < 5,-    blaze-builder >= 0.2.1.4 && <0.4,-    bytestring >= 0.9.1 && < 0.10,-    directory >= 1.0 && < 1.2,-    enumerator == 0.4.*,-    filepath >= 1.1 && <1.3,-    MonadCatchIO-transformers >= 0.2.1 && < 0.3,-    snap-core == 0.4.*,-    heist >= 0.5 && < 0.6,-    hint >= 0.3.3.1 && < 0.4,-    template-haskell >= 2.3 && < 2.6,-    time >= 1.0 && < 1.3--  if !os(windows) {-      build-depends:    unix >= 2.2.0.0 && < 2.5-  }+    aeson                     >= 0.6      && < 2.3,+    attoparsec                >= 0.10     && < 0.15,+    attoparsec-aeson          >= 2.1.0.0  && < 3.0,+    bytestring                >= 0.9.1    && < 0.13,+    cereal                    >= 0.3      && < 0.6,+    clientsession             >= 0.8      && < 0.10,+    configurator              >= 0.1      && < 0.4,+    containers                >= 0.2      && < 0.8,+    directory                 >= 1.1      && < 1.4,+    directory-tree            >= 0.11     && < 0.13,+    dlist                     >= 0.5      && < 1.1,+    filepath                  >= 1.3      && < 1.5,+    -- hashable is broken from 1.2.0.0 through 1.2.0.5+    -- snap does work with hashable 1.1.*, but some have complained that+    -- the version disjunction causes problems with dependency resolution.+    hashable                  >= 1.2.0.6  && < 1.5,+    heist                     >= 1.1      && < 1.2,+    lens                      >= 3.7.6    && < 5.3,+    lifted-base               >= 0.2      && < 0.3,+    map-syntax                >= 0.2      && < 0.4,+    monad-control             >= 0.3      && < 1.1,+    mtl                       >= 2.0      && < 2.4,+    mwc-random                >= 0.8      && < 0.16,+    pwstore-fast              >= 2.2      && < 2.5,+    snap-core                 >= 1.0      && < 1.1,+    snap-server               >= 1.0      && < 1.2,+    stm                       >= 2.2      && < 2.6,+    text                      >= 1.1.1.0  && < 2.2,+    time                      >= 1.1      && < 1.14,+    transformers              >= 0.2      && < 0.7,+    transformers-base         >= 0.4      && < 0.5,+    unordered-containers      >= 0.1.4    && < 0.3,+    xmlhtml                   >= 0.1      && < 0.3    if impl(ghc >= 6.12.0)-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields                  -fno-warn-orphans -fno-warn-unused-do-bind   else-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields                  -fno-warn-orphans -Executable snap-  hs-source-dirs: src-  main-is: Snap/Starter.hs+Test-suite testsuite+  import: universal+  hs-source-dirs: src test/suite+  type: exitcode-stdio-1.0+  main-is: TestSuite.hs -  other-modules: Snap.StarterTH+  autogen-modules:+    Paths_snap +  other-modules:+    Blackbox.Tests+    Paths_snap+    SafeCWD+    Snap+    Snap.Snaplet+    Snap.Snaplet.Auth+    Snap.Snaplet.Auth.AuthManager+    Snap.Snaplet.Auth.Backends.JsonFile+    Snap.Snaplet.Auth.Handlers+    Snap.Snaplet.Auth.Handlers.Tests+    Snap.Snaplet.Auth.SpliceHelpers+    Snap.Snaplet.Auth.SpliceTests+    Snap.Snaplet.Auth.Tests+    Snap.Snaplet.Auth.Types+    Snap.Snaplet.Auth.Types.Tests+    Snap.Snaplet.Test.Common.App+    Snap.Snaplet.Test.Common.BarSnaplet+    Snap.Snaplet.Test.Common.EmbeddedSnaplet+    Snap.Snaplet.Test.Common.FooSnaplet+    Snap.Snaplet.Test.Common.Handlers+    Snap.Snaplet.Test.Common.Types+    Snap.Snaplet.Config+    Snap.Snaplet.Config.Tests+    Snap.Snaplet.Heist+    Snap.Snaplet.Heist.Compiled+    Snap.Snaplet.Heist.Generic+    Snap.Snaplet.Heist.Internal+    Snap.Snaplet.Heist.Interpreted+    Snap.Snaplet.Heist.Tests+    Snap.Snaplet.HeistNoClass+    Snap.Snaplet.Internal.Initializer+    Snap.Snaplet.Internal.LensT+    Snap.Snaplet.Internal.LensT.Tests+    Snap.Snaplet.Internal.Lensed+    Snap.Snaplet.Internal.Lensed.Tests+    Snap.Snaplet.Internal.RST+    Snap.Snaplet.Internal.RST.Tests+    Snap.Snaplet.Internal.Tests+    Snap.Snaplet.Internal.Types+    Snap.Snaplet.Session+    Snap.Snaplet.Session.Backends.CookieSession+    Snap.Snaplet.Session.Common+    Snap.Snaplet.Session.SecureCookie+    Snap.Snaplet.Session.SessionManager+    Snap.Snaplet.Test+    Snap.Snaplet.Test.Tests+    Snap.TestCommon+   build-depends:-    attoparsec >= 0.8.0.2 && < 0.9,-    base >= 4 && < 5,+    aeson,+    async                      >= 2.0.1.5  && < 2.3,+    attoparsec,+    attoparsec-aeson,     bytestring,-    bytestring-nums,-    cereal >= 0.3 && < 0.4,+    cereal,+    clientsession,+    configurator,     containers,-    directory >= 1.0 && < 1.2,+    deepseq,+    directory,     directory-tree,-    dlist >= 0.5 && < 0.6,-    enumerator == 0.4.*,-    filepath >= 1.1 && <1.3,-    haskell98,-    mtl >= 2,-    old-locale,-    old-time,-    snap-core >= 0.4 && <0.5,-    snap-server >= 0.4 && <0.5,-    template-haskell >= 2.3 && < 2.6,-    text >= 0.11 && <0.12,+    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,-    unix-compat,-    zlib--  ghc-prof-options: -prof -auto-all--  if impl(ghc >= 6.12.0)-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-orphans -fno-warn-unused-do-bind-  else-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-orphans+    transformers,+    transformers-base,+    unordered-containers,+    xmlhtml  source-repository head   type:     git-  location: http://git.snapframework.com/snap.git+  location: https://github.com/snapframework/snap.git
+ src/Snap.hs view
@@ -0,0 +1,18 @@+{-|++This module provides convenience exports of the modules most commonly used+when developing with the Snap Framework.  For documentation about Snaplets,+see "Snap.Snaplet".  For the core web server API, see "Snap.Core".++-}++module Snap+  ( module Snap.Core+  , module Snap.Http.Server+  , module Snap.Snaplet+  ) where++import Snap.Core+import Snap.Http.Server+import Snap.Snaplet+
− src/Snap/Extension.hs 
@@ -1,500 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}--module Snap.Extension-  ( -- * Introduction-    -- $introduction--    -- ** Using Snap Extensions-    -- $using--    -- *** Define Application State and Monad-    -- $definingtypes--    -- *** Provide Instances For \"HasState\" Classes-    -- $hasstateclasses--    -- *** Define The Initializer-    -- $initializer--    -- *** Simplified Snap Extension Server-    -- $httpserve--    SnapExtend-  , Initializer-  , InitializerState(..)-  , runInitializer-  , runInitializerWithReloadAction-  , runInitializerWithoutReloadAction-  , mkInitializer-  , defaultReloadHandler-  , nullReloadHandler-  ) where--import           Blaze.ByteString.Builder-import           Control.Applicative-import           Control.Exception (SomeException)-import           Control.Monad-import           Control.Monad.CatchIO-import           Control.Monad.Reader-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import           Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import           Prelude hiding (catch, init)-import           Snap.Iteratee (enumBuilder, (>==>))-import           Snap.Types-import           System.IO---{- $introduction--  Snap Extensions is a library which makes it easy to create reusable plugins-  that extend your Snap application with modular chunks of functionality such-  as session management, user authentication, templating, or database-  connection pooling.--  We achieve this by requiring that you create a datatype that holds an-  environment for your application and wrap it around the Snap monad. This new-  construct becomes your application's handler monad and gives you access to-  your application state throughout your handlers.--  Warning: this interface is still EXPERIMENTAL and has a very high likelihood-  of changing substantially in coming versions of Snap.---}--{- $using--  Every extension has an interface and at least one implementation of that-  interface.--  For some extensions, like Heist, there is only ever going to be one-  implementation of the interface. In these cases, both the interface and the-  implementation are exported from the same module, Snap.Extension.Heist.Impl.--  Hypothetically, for something like session management though, there could be-  multiple implementations, one using a HDBC backend, one using a MongoDB-  backend and one just using an encrypted cookie as backend. In these cases,-  the interface is exported from Snap.Extension.Session, and the-  implementations live in Snap.Extension.Session.HDBC,-  Snap.Extension.Session.MongoDB and Snap.Extension.Session.CookieStore.--  Keeping this in mind, there are a number of things you need to do to use-  Snap extensions in your application. Let's walk through how to set up a-  simple application with the Heist extension turned on.---}--{- $definingtypes--  First, we define a record type AppState for holding our application's state,-  including the state needed by the extensions we're using.--  At the same time, we also define the monad for our application, App, as-  a type alias to @SnapExtend AppState@. 'SnapExtend' is a 'MonadSnap' and-  a 'MonadReader', whose environment is a given type; in our case, AppState.--  @-module App where--import Database.HDBC-import Database.HDBC.ODBC-import Snap.Extension-import Snap.Extension.Heist-import Snap.Types--type App = SnapExtend AppState--data AppState = AppState-    { heistState  :: HeistState App }-  @--  An important thing to note is that the -State types that we use in the-  fields of AppState are specific to each implementation of a extension's-  interface.  That is, Snap.Extension.Session.HDBC will export a different-  SessionState to Snap.Extension.Session.CookieStore, whose internal-  representation might be completely different.--  This state is what the extension's implementation needs to be able to do its-  job.---}--{- $hasstateclasses--  Now we have a datatype that contains all the internal state needed by our-  application and the extensions it uses. That's a great start! But when do we-  actually get to use this interface and all the functionality that these-  extensions export?  What is actually being extended?--  We use the interface provided by an extension inside our application's-  monad, App. Snap extensions extend our App with new functionality by-  allowing us to user their exported functions inside of our handlers. For-  example, the Heist extension provides the function:--  @render :: MonadHeist m => ByteString -> m ()@ that renders a template by-  its name.--  Is App a 'MonadHeist'? Well, not quite yet. Any 'MonadReader' which is also-  a 'MonadSnap' whose environment contains a 'HeistState' is a 'MonadHeist'.-  That sounds a lot like our App, doesn't it? We just have to tell the Heist-  extension how to find the 'HeistState' in our AppState:--  @-instance HasHeistState AppState where-    getHeistState = heistState-    setHeistState hs as = as { heistState = hs }-  @--  Stated another way, if we give our AppState the ability to hold a HeistState-  and let the HasHeistState typeclass know how to get/set this state, we are-  /automagically/ given the ability to render heist templates in our handlers.--  With these instances, our application's monad App is now a MonadHeist-  giving it access to operations like:--  @render :: MonadHeist m => ByteString -> m ()@--  and--  @heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a@---}--{- $initializer--  So, our monad is now a 'MonadHeist', but how do we actually construct our-  AppState and turn an App () into a 'Snap' ()? We need to do this upfront,-  once and right before our web server starts listening for connections.--  Snap extensions have a thing called an 'Initializer' that does these things.-  Each implementation of a Snap extension interface provides an 'Initializer'-  for its -State type. We must construct an initializer type for our -State-  type, AppState. An 'Initializer' monad is provided in this library to make-  it easy to do this. For your convenience, 'Initializer' is an instance of-  'MonadIO'.--  @-appInitializer :: Initializer AppState-appInitializer = do-    hs <- heistInitializer \"resources/templates\"-    return $ AppState hs-  @--  In addition to constructing the AppState, the Initializer monad also-  constructs the init, destroy and reload functions for our application from-  the init, reload and destroy functions for the extensions.--  Although it won't cause a compile-time error, it is important to get the-  order of the initializers correct as much as possible, otherwise they may be-  reloaded and destroyed in the wrong order. The "right" order is an order-  where every extension's dependencies are initialised before that extension.-  For example, Snap.Extension.Session.HDBC would depend on something which-  would extend the monad with MonadConnectionPool, i.e.,-  Snap.Extension.ConnectionPool. If you had this configuration it would be-  important that you put the connectionPoolInitializer before the-  sessionInitializer in your appInitializer.--  This Initializer AppState can then be passed to 'runInitializer', which-  combines our initializer action with our application's handler to produce a-  'Snap' handler (which can be passed to 'httpServe'), a cleanup action (which-  you can run after 'httpServe' finishes), and a reload action (which, for-  example, you may want to use in your handler for the path \"admin/reload\".--  The following is an example of how you might use this in main:--  @-main :: IO ()-main = do-    (snap,cleanup,reload) <- runInitializer appInitializer appSite-    let site = snap-               <|> path "admin/reload" $ defaultReloadHandler reload cleanup-    quickHttpServe site `finally` cleanup-  @--  You'll notice we're using 'defaultReloadHandler'. This is a function-  exported by "Snap.Extension" with the type signature--  @MonadSnap m => IO [(ByteString, Maybe ByteString)] -> m ()@ It takes the-  reload action returned by 'runInitializer' and returns a 'Snap' action which-  renders a simple page showing how the reload went. To avoid denial of-  service attacks, the reload handler only works for requests made from the-  local host.---}--{- $httpserve-- This is, of course, a lot of avoidable boilerplate. Snap extensions framework- comes with another module "Snap.Extension.Server", which provides an- interface mimicking that of "Snap.Http.Server". Their function names clash,- so if you need to use both of them in the same module, use a qualified- import. Using this module, the example above becomes:--  @-import Snap.Extension.Server--main :: IO ()-main = quickHttpServe appRunner site-  @--  All it needs is a Initializer AppState and an App () and it is ready to go.-  You might be wondering what happened to all the reload handler bits we-  had before: That stuff has been absorbed into the config for the server.--  One quick note: 'quickHttpServe' doesn't take a config, instead it uses the-  defaults augmented with any options specified on the command-line.  The-  default reload handler path in this case is "admin/reload".--  If you wanted to change this to nullReloadHandler, you would do this:--  @-import Snap.Extension.Server--main :: IO ()-main = do-    config <- commandLineConfig emptyConfig-    httpServe (setReloadHandler nullReloadHandler config) appRunner site-  @--  This behaves exactly as the above example apart from the reload handler.--  With this, we now have a fully functional base application that makes use of-  the Snap Extensions mechanism.--  To initialize a directory with all of this setup provided as a starting-  point, simply @cd@ into the desired location and type: @snap init@. An-  example \"Timer\" extension will also be included for your convenience.---}----------------------------------------------------------------------------------- | A 'SnapExtend' is a 'MonadReader' and a 'MonadSnap' whose environment is--- the application state for a given progam. You would usually type alias--- @SnapExtend AppState@ to something like @App@ to form the monad in which--- you write your application.-newtype SnapExtend s a = SnapExtend (ReaderT s Snap a)-  deriving-    ( Functor-    , Applicative-    , Alternative-    , Monad-    , MonadPlus-    , MonadIO-    , MonadCatchIO-    , MonadSnap-    , MonadReader s-    )------------------------------------------------------------------------------------ | The 'SCR' datatype is used internally by the 'Initializer' monad to store--- the application's state, cleanup actions and reload actions.-data SCR s = SCR-    { _state   :: s-      -- ^ The internal state of the application's Snap Extensions.-    , _cleanup :: IO ()-      -- ^ IO action which when run will cleanup the application's state,-      -- e.g., closing open connections.-    , _reload  :: IO [(ByteString, Maybe ByteString)]-      -- ^ IO action which when run will reload the application's state, e.g.,-      -- refreshing any cached values stored in the state.-      ---      -- It returns a list of tuples whose \"keys\" are the names of the Snap-      -- Extensions which were reloaded and whose \"values\" are @Nothing@-      -- when run successfully and @Just x@ on failure, where @x@ is an error-      -- message.-    }------------------------------------------------------------------------------------ | The 'Initializer' monad. The code that initialises your application's--- state is written in the 'Initializer' monad. It's used for constructing--- values which have cleanup\/destroy and reload actions associated with them.-newtype Initializer s = Initializer (Bool -> IO (Either s (SCR s)))------------------------------------------------------------------------------------ | Values of types which are instances of 'InitializerState' have--- cleanup\/destroy and reload actions associated with them.-class InitializerState s where-    extensionId :: s -> ByteString-    mkCleanup   :: s -> IO ()-    mkReload    :: s -> IO ()------------------------------------------------------------------------------------ | Although it has the same type signature, this is not the same as 'return'--- in the 'Initializer' monad. Return simply lifts a value into the--- 'Initializer' monad, but this lifts the value and its destroy\/reload--- actions. Use this when making your own 'Initializer' actions.-mkInitializer :: InitializerState s => s -> Initializer s-mkInitializer s = Initializer $ \v -> setup v $ Right $ mkSCR v-  where-    handler          :: SomeException -> IO (Maybe ByteString)-    handler e        = return $ Just $ toUTF8 $ show e-    maybeCatch m     = (m >> return Nothing) `catch` handler-    maybeToMsg       = maybe " done." $ const " failed."-    name             = fromUTF8 $ extensionId s-    mkSCR v          = SCR s (cleanup v) (reload v)-    cleanup v        = do-        when v $ hPutStr stderr $ "Cleaning up " ++ name ++ "..."-        m <- maybeCatch $ mkCleanup s-        when v $ hPutStrLn stderr $ maybeToMsg m-    reload v         = do-        when v $ hPutStr stderr $ "Reloading " ++ name ++ "..."-        m <- maybeCatch $ mkReload s-        when v $ hPutStrLn stderr $ maybeToMsg m-        return [(extensionId s, m)]-    setup v r        = do-        when v $ hPutStrLn stderr $ "Initializing " ++ name ++ "... done."-        return r------------------------------------------------------------------------------------ | Given the Initializer for your application's state, and a value in the--- monad formed by 'SnapExtend' wrapped it, this returns a 'Snap' action, a--- cleanup action and a reload action.-runInitializer-  :: Bool-    -- ^ Verbosity; info is printed to 'stderr' when this is 'True'-  -> Initializer s-    -- ^ The Initializer value-  -> SnapExtend s ()-    -- ^ A web handler in your application's monad-  -> IO (Snap (), IO (), IO [(ByteString, Maybe ByteString)])-     -- ^ Returns a 'Snap' handler, a cleanup action, and a reload action. The-     -- list returned by the reload action is for error reporting. There is-     -- one tuple in the list for each Snap extension; the first element of-     -- the tuple is the name of the Snap extension, and the second is a Maybe-     -- which contains Nothing if there was no error reloading that extension-     -- and a Just with the ByteString containing the error message if there-     -- was.-runInitializer v (Initializer r) (SnapExtend m) =-    r v >>= \e -> case e of-        Left s            -> return (runReaderT m s, return (), return [])-        Right (SCR s a b) -> return (runReaderT m s, a, b)------------------------------------------------------------------------------------ | Serves the same purpose as 'runInitializer', but combines the---   application's web handler with a user-supplied action to be run to reload---   the application's state.-runInitializerWithReloadAction-  :: Bool-    -- ^ Verbosity; info is printed to 'stderr' when this is 'True'-  -> Initializer s-    -- ^ The Initializer value-  -> SnapExtend s ()-    -- ^ A web handler in your application's monad.-  -> (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())-    -- ^ Your desired \"reload\" handler; it gets passed the reload-    -- action. This handler is always run, so you have to guard the path-    -- yourself (with.-  -> IO (Snap (), IO ())-    -- ^ Your 'Snap' handler and a cleanup action.-runInitializerWithReloadAction v (Initializer r) se f = do-    (state, cleanup, reload) <- runInit--    let (SnapExtend m') = f reload <|> se-    return (runReaderT m' state, cleanup)--  where-    runInit = r v >>= \e ->-              case e of-                Left s            -> return (s, return (), return [])-                Right (SCR s a b) -> return (s, a, b)----------------------------------------------------------------------------------- | A cut-down version of 'runInitializer', for use by the hint--- loading code-runInitializerWithoutReloadAction :: Initializer s-                                  -- ^ The Initializer value-                                  -> SnapExtend s ()-                                  -- ^ An action in your application's monad.-                                  -> IO (Snap (), IO ())-runInitializerWithoutReloadAction i se = do-    (action, cleanup, _) <- runInitializer True i se-    return (action, cleanup)----------------------------------------------------------------------------------instance Functor Initializer where-    fmap f (Initializer r) = Initializer $ \v -> r v >>= \e -> return $-        case e of-            Left s            -> Left $ f s-            Right (SCR s a b) -> Right $ SCR (f s) a b----------------------------------------------------------------------------------instance Applicative Initializer where-    pure  = return-    (<*>) = ap----------------------------------------------------------------------------------instance Monad Initializer where-    return   = Initializer . const . return . Left-    a >>= f  = join' $ fmap f a----------------------------------------------------------------------------------instance MonadIO Initializer where-    liftIO = Initializer . const . fmap Left------------------------------------------------------------------------------------ | Join for the 'Initializer' monad. This is used in the definition of bind--- for the 'Initializer' monad.-join' :: Initializer (Initializer s) -> Initializer s-join' (Initializer r) = Initializer $ \v -> r v >>= \e -> case e of-    Left  (Initializer r')           -> r' v-    Right (SCR (Initializer r') a b) -> r' v >>= \e' -> return $ Right $-        case e' of-            Left  s             -> SCR s a b-            Right (SCR s a' b') -> SCR s (a' >> a) (liftM2 (++) b b')------------------------------------------------------------------------------------ | This takes the last value of the tuple returned by 'runInitializer',--- which is a list representing the results of an attempt to reload the--- application's Snap Extensions, and turns it into a Snap action which--- displays the these results.-defaultReloadHandler :: MonadSnap m-                     => IO [(ByteString, Maybe ByteString)]-                     -> m ()-defaultReloadHandler ioms = failIfNotLocal $ do-    ms <- liftIO $ ioms-    let showE e       = mappend "Error: "  $ toUTF8 $ show e-        format (n, m) = mconcat [n, ": ", maybe "Success" showE m, "\n"]-        msg           = mconcat $ map format ms-    finishWith $ setContentType "text/plain; charset=utf-8"-        $ setContentLength (fromIntegral $ B.length msg)-        $ modifyResponseBody (>==> enumBuilder (fromByteString msg))-                             emptyResponse-  where-    failIfNotLocal m = do-        rip <- liftM rqRemoteAddr getRequest-        if not $ elem rip [ "127.0.0.1"-                          , "localhost"-                          , "::1" ]-          then pass-          else m----------------------------------------------------------------------------------- | Use this reload handler to disable the ability to have a web handler--- which reloads Snap extensions.-nullReloadHandler :: MonadSnap m-                  => IO [(ByteString, Maybe ByteString)]-                  -> m ()-nullReloadHandler = const pass----------------------------------------------------------------------------------fromUTF8 :: ByteString -> String-fromUTF8 = T.unpack . T.decodeUtf8--toUTF8 :: String -> ByteString-toUTF8 = T.encodeUtf8 . T.pack
− src/Snap/Extension/Heist.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}--{-|--'Snap.Extension.Heist' exports the 'MonadHeist' interface which allows you to-integrate Heist templates into your Snap application. The interface's-operations are 'heistServe', 'heistServeSingle', 'heistLocal' and 'render'. As-a convenience, we also provide 'renderWithSplices' that combines 'heistLocal'-and 'render' into a single function call.--'Snap.Extension.Heist.Impl' contains the only implementation of this interface-and can be used to turn your application's monad into a 'MonadHeist'.--'MonadHeist' is unusual among Snap extensions in that it's a multi-parameter-typeclass. The last parameter is your application's monad, and the first is-the monad you want the 'TemplateState' to use. This is usually, but not-always, also your application's monad.--This module should not be used directly. Instead, import-"Snap.Extension.Heist.Impl" in your application.---}--module Snap.Extension.Heist-  ( MonadHeist(..)-  , renderWithSplices ) where--import           Control.Applicative-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import           Data.Text (Text)-import           Snap.Types-import           Snap.Util.FileServe-import           Text.Templating.Heist------------------------------------------------------------------------------------ | The 'MonadHeist' type class. Minimal complete definition: 'render',--- 'heistLocal'.-class (Monad n, MonadSnap m) => MonadHeist n m | m -> n where-    -- | Renders a template as text\/html. If the given template is not found,-    -- this returns 'empty'.-    render     :: ByteString -> m ()--    -- | Renders a template as the given content type.  If the given template-    -- is not found, this returns 'empty'.-    renderAs   :: ByteString -> ByteString -> m ()--    -- | Runs an action with a modified 'TemplateState'. You might want to use-    -- this if you had a set of splices which were customised for a specific-    -- action. To do that you would do:-    ---    -- > heistLocal (bindSplices mySplices) $ render "myTemplate"-    heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a--    -- | Analogous to 'fileServe'. If the template specified in the request-    -- path is not found, it returns 'empty'.-    heistServe :: m ()-    heistServe = ifTop (render "index") <|> (render . B.pack =<< getSafePath)--    -- | Analogous to 'fileServeSingle'. If the given template is not found,-    -- this throws an error.-    heistServeSingle :: ByteString -> m ()-    heistServeSingle t = render t-        <|> error ("Template " ++ show t ++ " not found.")------------------------------------------------------------------------------------ | Helper function for common use case:--- Render a template with a given set of splices.-renderWithSplices-  :: (MonadHeist n m)-  => ByteString                 -- ^ Template to render-  -> [(Text, Splice n)]   -- ^ Splice mapping-  -> m ()-renderWithSplices t sps = heistLocal bsps $ render t-  where bsps = bindSplices sps
− src/Snap/Extension/Heist/Impl.hs 
@@ -1,210 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}--{-|--'Snap.Extension.Heist.Impl' is an implementation of the 'MonadHeist'-interface defined in 'Snap.Extension.Heist'.--As always, to use, add 'HeistState' to your application's state, along with an-instance of 'HasHeistState' for your application's state, making sure to-use a 'heistInitializer' in your application's 'Initializer', and then you're-ready to go.--'Snap.Extension.Heist.Impl' is a little different to other Snap Extensions,-which is unfortunate as it is probably the most widely useful one. As-explained below, 'HeistState' takes your application's monad as a type-argument, and 'HasHeistState' is a multi-parameter type class, the additional-first parameter also being your application's monad.--Two instances of 'MonadHeist' are provided with this module. One is designed-for users wanting to use Heist templates with their application, the other is-designed for users writing Snap Extensions which use their own Heist templates-internally.--The first one of these instances is-@HasHeistState (SnapExtend s) s => MonadHeist (SnapExtend s) (SnapExtend s)@.-This means that any type @s@ which has a 'HeistState', whose-'TemplateState'\'s monad is @SnapExtend s@ forms a 'MonadHeist' whose-'TemplateState'\'s monad is @SnapExtend s@ and whose monad itself is-@SnapExtend s@. The @s@ here is your application's state, and @SnapExtend s@-is your application's monad.--The second one of these instances is-@HasHeistState m s => MonadHeist m (ReaderT s m)@. This means that any type-@s@ which has, for any m, a @HeistState m@, forms a 'MonadHeist', whose-'TemplateState'\'s monad is @m@, when made the environment of-a 'ReaderT' wrapped around @m@. The @s@ here would be the Snap Extension's-internal state, and the @m@ would be 'SnapExtend' wrapped around any @s'@-which was an instance of the Snap Extension's @HasState@ class.--This implementation does not require that your application's monad implement-interfaces from any other Snap Extension.---}--module Snap.Extension.Heist.Impl-  (--    -- * Heist State Definitions-    HeistState-  , HasHeistState(..)-  , heistInitializer--    -- * The MonadHeist Interface-  , MonadHeist(..)--    -- * Convenience Functions-  , registerSplices-  ) where--import           Control.Concurrent.MVar-import           Control.Monad.Reader-import           Data.ByteString (ByteString)-import           Data.Maybe-import           Data.Text (Text)-import           Snap.Extension-import           Snap.Extension.Heist-import           Snap.Types-import           Text.Templating.Heist-import           Text.Templating.Heist.Splices.Static------------------------------------------------------------------------------------ | Your application's state must include a 'HeistState' in order for your--- application to be a 'MonadHeist'.------ Unlike other @-State@ types, this is of kind @(* -> *) -> *@. Unless you're--- developing your own Snap Extension which has its own internal 'HeistState',--- the type argument you want to pass to 'HeistState' is your application's--- monad, which should be 'SnapExtend' wrapped around your application's--- state.-data MonadSnap m => HeistState m = HeistState-    { _path     :: FilePath-    , _origTs   :: TemplateState m-    , _tsMVar   :: MVar (TemplateState m)-    , _sts      :: StaticTagState-    , _modifier :: TemplateState m -> TemplateState m-    }------------------------------------------------------------------------------------ | For your application's monad to be a 'MonadHeist', your application's--- state needs to be an instance of 'HasHeistState'. Minimal complete--- definition: 'getHeistState', 'setHeistState'.------ Unlike other @HasState@ type classes, this is a type class has two--- parameters. Among other things, this means that you will need to enable the--- @FlexibleInstances@ and @MultiParameterTypeClasses@ language extensions to--- be able to create an instance of @HasHeistState@. In most cases, the last--- parameter will as usual be your application's state, and the additional--- first one will be the monad formed by wrapping 'SnapExtend' around your--- application's state.------ However, if you are developing your own Snap Extension which uses its own--- internal 'HeistState', the last parameter will be your Snap Extension's--- internal state, and the additional first parameter will be any monad formed--- by wrapping @SnapExtend@ around a type which has an instance of the--- @HasState@ class for your monad. These two use cases are subtly different,--- which is why 'HasHeistState' needs two type parameters.-class MonadSnap m => HasHeistState m s | s -> m where-    getHeistState :: s -> HeistState m-    setHeistState :: HeistState m -> s -> s--    modifyHeistState :: (HeistState m -> HeistState m) -> s -> s-    modifyHeistState f s = setHeistState (f $ getHeistState s) s------------------------------------------------------------------------------------ | The 'Initializer' for 'HeistState'. It takes one argument, a path to a--- template directory containing @.tpl@ files.-heistInitializer :: MonadSnap m => FilePath -> Initializer (HeistState m)-heistInitializer p = do-    heistState <- liftIO $ do-        (origTs,sts) <- bindStaticTag $ emptyTemplateState p-        loadTemplates p origTs >>= either error (\ts -> do-            tsMVar <- newMVar ts-            return $ HeistState p origTs tsMVar sts id)-    mkInitializer heistState----------------------------------------------------------------------------------instance MonadSnap m => InitializerState (HeistState m) where-    extensionId = const "Heist/Impl"-    mkCleanup   = const $ return ()-    mkReload (HeistState p origTs tsMVar sts _) = do-        clearStaticTagCache $ sts-        either error (modifyMVar_ tsMVar . const . return) =<<-            loadTemplates p origTs----------------------------------------------------------------------------------instance HasHeistState (SnapExtend s) s-      => MonadHeist (SnapExtend s) (SnapExtend s) where-    render t = do-        hs <- asks getHeistState-        renderHelper hs Nothing t--    renderAs c t = do-        hs <- asks getHeistState-        renderHelper hs (Just c) t--    heistLocal f = local $ modifyHeistState $ \s ->-        s { _modifier = f . _modifier s }----------------------------------------------------------------------------------instance HasHeistState m s => MonadHeist m (ReaderT s m) where-    render t = ReaderT $ \s -> renderHelper (getHeistState s) Nothing t--    renderAs c t = ReaderT $ \s -> renderHelper (getHeistState s) (Just c) t--    heistLocal f = local $ modifyHeistState $ \s ->-        s { _modifier = f . _modifier s }----------------------------------------------------------------------------------renderHelper :: (MonadSnap m)-             => HeistState m-             -> Maybe MIMEType-             -> ByteString-             -> m ()-renderHelper hs c t = do-    let (HeistState _ _ tsMVar _ modifier) = hs-    ts <- liftIO $ fmap modifier $ readMVar tsMVar-    renderTemplate ts t >>= maybe pass (\(b,mime) -> do-        modifyResponse $ setContentType $ fromMaybe mime c-        writeBuilder b)------------------------------------------------------------------------------------ | Take your application's state and register these splices in it so--- that you don't have to re-list them in every handler. Should be called from--- inside your application's 'Initializer'.------ Typical use cases are dynamically generated components that are present in--- many of your views.------ Example Usage:------ @--- appInit :: Initializer AppState--- appInit = do---  hs <- heistInitializer \"templates\"---  registerSplices hs $---   [ (\"tabs\", tabsSplice)---   , (\"loginLogout\", loginLogoutSplice) ]--- @-registerSplices-  :: (MonadSnap m, MonadIO n)-  => HeistState m-  -- ^ Heist state that you are going to embed in your application's state.-  -> [(Text, Splice m)]-  -- ^ Your splices.-  -> n ()-registerSplices s sps = liftIO $ do-  let mv = _tsMVar s-  modifyMVar_ mv $ (return . bindSplices sps)
− src/Snap/Extension/Loader/Devel.hs 
@@ -1,159 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# 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.Extension.Loader.Devel-  ( loadSnapTH-  ) where--import           Control.Monad (liftM2)--import           Data.List-import           Data.Maybe (catMaybes)-import           Data.Time.Clock (diffUTCTime, getCurrentTime)--import           Language.Haskell.Interpreter hiding (lift, liftIO)-import           Language.Haskell.Interpreter.Unsafe--import           Language.Haskell.TH--import           System.Environment (getArgs)---------------------------------------------------------------------------------import           Snap.Types-import           Snap.Extension (runInitializerWithoutReloadAction)-import           Snap.Extension.Loader.Devel.Signal-import           Snap.Extension.Loader.Devel.Evaluator-import           Snap.Extension.Loader.Devel.TreeWatcher----------------------------------------------------------------------------------- | 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 :: Initializer s -> SnapExtend s () -> [String] -> IO (Snap ())------ with a magical implementation.------ The upshot is that you shouldn't need to recompile your server--- during development unless your .cabal file changes, or the code--- that uses this splice changes.-loadSnapTH :: Name -> Name -> [String] -> Q Exp-loadSnapTH initializer action additionalWatchDirs = do-    args <- runIO getArgs--    let initMod = nameModule initializer-        initBase = nameBase initializer-        actMod = nameModule action-        actBase = nameBase action--        opts = getHintOpts args-        modules = catMaybes [initMod, actMod]-        srcPaths = additionalWatchDirs ++ getSrcPaths args--    -- The let in this block causes an extra static type check that the-    -- types of the names passed in were correct at compile time.-    [| let _ = runInitializerWithoutReloadAction $(varE initializer)-                                                 $(varE action)-       in hintSnap opts modules srcPaths initBase actBase |]------------------------------------------------------------------------------------ | Convert the command-line arguments passed in to options for the--- hint interpreter.  This is somewhat brittle code, based on a few--- experimental datapoints regarding the structure of the command-line--- arguments cabal produces.-getHintOpts :: [String] -> [String]-getHintOpts args = removeBad opts-  where-    bad = ["-threaded", "-O"]-    removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad)--    hideAll = filter (== "-hide-all-packages") args--    srcOpts = filter (\x -> "-i" `isPrefixOf` x-                            && not ("-idist" `isPrefixOf` x)) args--    toCopy = filter (not . isSuffixOf ".hs") $-             dropWhile (not . ("-package" `isPrefixOf`)) args-    copy = map (intercalate " ") . groupBy (\_ s -> not $ "-" `isPrefixOf` s)--    opts = hideAll ++ srcOpts ++ copy toCopy------------------------------------------------------------------------------------ | This function extracts the source paths from the compilation args-getSrcPaths :: [String] -> [String]-getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg-  where-    srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x)------------------------------------------------------------------------------------ | This function creates the Snap handler that actually is--- responsible for doing the dynamic loading of actions via hint,--- given all of the configuration information that the interpreter--- needs.  It also ensures safe concurrent access to the interpreter,--- and caches the interpreter results for a short time before allowing--- it to run again.------ Generally, this won't be called manually.  Instead, loadSnapTH will--- generate a call to it at compile-time, calculating all the--- arguments from its environment.-hintSnap :: [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 initializer action-         -> String   -- ^ The name of the SnapExtend action-         -> IO (Snap ())-hintSnap opts modules srcPaths initialization handler =-    protectedHintEvaluator initialize test loader-  where-    action = intercalate " " [ "runInitializerWithoutReloadAction"-                             , initialization-                             , handler-                             ]-    interpreter = do-        loadModules . nub $ modules-        let imports = "Prelude" :-                      "Snap.Extension" :-                      "Snap.Types" :-                      modules-        setImports . nub $ imports--        interpret action (as :: HintLoadable)--    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)-
− src/Snap/Extension/Loader/Devel/Evaluator.hs 
@@ -1,137 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Extension.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.Types (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 an action to--- generate Snap actions.  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 ())-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.-    return $ 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, _)           -> do-                        _ <- swapMVar resultContainer Nothing-                        waitForNewResult-            Nothing -> waitForNewResult-        getResult-  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/Extension/Loader/Devel/Signal.hs 
@@ -1,43 +0,0 @@-{-# LANGUAGE CPP #-}-module Snap.Extension.Loader.Devel.Signal (protectHandlers) where--import Control.Exception (bracket)--#ifdef mingw32_HOST_OS-import GHC.ConsoleHandler as C---saveHandlers :: IO C.Handler-saveHandlers = C.installHandler Ignore---restoreHandlers :: C.Handler -> IO C.Handler-restoreHandlers = C.installHandler---#else-import qualified System.Posix.Signals as S--helper :: S.Handler -> S.Signal -> IO S.Handler-helper handler signal = S.installHandler signal handler Nothing---signals :: [S.Signal]-signals = [ S.sigQUIT-          , S.sigINT-          , S.sigHUP-          , S.sigTERM-          ]---saveHandlers :: IO [S.Handler]-saveHandlers = mapM (helper S.Ignore) signals---restoreHandlers :: [S.Handler] -> IO [S.Handler]-restoreHandlers h = sequence $ zipWith helper h signals---#endif-protectHandlers :: IO a -> IO a-protectHandlers a = bracket saveHandlers restoreHandlers $ const a
− src/Snap/Extension/Loader/Devel/TreeWatcher.hs 
@@ -1,46 +0,0 @@-module Snap.Extension.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 adtEq entries-    adtEq (n1 :/ dt1) (n2 :/ dt2) = n1 == n2 && dtEq dt1 dt2--    dtEq (Dir n1 d1) (Dir n2 d2) = n1 == n2 && and (zipWith dtEq d1 d2)-    dtEq (File n1 t1) (File n2 t2) = n1 == n2 && t1 == t2-    dtEq _ _ = False------------------------------------------------------------------------------------ | 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/Extension/Server.hs 
@@ -1,153 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}--{-|--This module provides replacements for the 'httpServe' and 'quickHttpServe'-functions exported by 'Snap.Http.Server'. By taking a 'Initializer' as an-argument, these functions simplify the glue code that is needed to use Snap-Extensions.---}--module Snap.Extension.Server-  ( ConfigExtend-  , httpServe-  , quickHttpServe-  , defaultConfig-  , getReloadHandler-  , setReloadHandler-  , module Snap.Http.Server.Config-  ) where--import           Control.Exception (SomeException)-import           Control.Monad-import           Control.Monad.CatchIO-import           Data.ByteString (ByteString)-import           Data.Maybe-import           Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import           Prelude hiding (catch)-import           Snap.Extension-import           Snap.Http.Server (simpleHttpServe)-import qualified Snap.Http.Server.Config as C-import           Snap.Http.Server.Config hiding ( defaultConfig-                                                , completeConfig-                                                , getOther-                                                , setOther-                                                )-import           Snap.Util.GZip-import           Snap.Types-import           System.IO------------------------------------------------------------------------------------ | 'ConfigExtend' is similar to the 'Config' exported by 'Snap.Http.Server',--- but is augmented with a @reloadHandler@ field which can be accessed using--- 'getReloadHandler' and 'setReloadHandler'.-type ConfigExtend s = Config-    (SnapExtend s) (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())----------------------------------------------------------------------------------getReloadHandler :: ConfigExtend s -> Maybe-                      (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())-getReloadHandler = C.getOther----------------------------------------------------------------------------------setReloadHandler :: (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())-                 -> ConfigExtend s-                 -> ConfigExtend s-setReloadHandler = C.setOther-------------------------------------------------------------------------------------- | These are the default values for all the fields in 'ConfigExtend'.------ > hostname      = "localhost"--- > address       = "0.0.0.0"--- > port          = 8000--- > accessLog     = "log/access.log"--- > errorLog      = "log/error.log"--- > locale        = "en_US"--- > compression   = True--- > verbose       = True--- > errorHandler  = prints the error message--- > reloadHandler = prints the result of each reload handler (error/success)----defaultConfig :: ConfigExtend s-defaultConfig = setReloadHandler handler C.defaultConfig-  where-    handler = path "admin/reload" . defaultReloadHandler------------------------------------------------------------------------------------ | Completes a partial 'Config' by filling in the unspecified values with--- the default values from 'defaultConfig'.-completeConfig :: ConfigExtend s -> ConfigExtend s-completeConfig c = case getListen c' of-                    [] -> addListen (ListenHttp "0.0.0.0" 8000) c'-                    _ -> c'-  where c' = mappend defaultConfig c------------------------------------------------------------------------------------ | Starts serving HTTP requests using the given handler, with settings from--- the 'ConfigExtend' passed in. This function never returns; to shut down--- the HTTP server, kill the controlling thread.-httpServe :: ConfigExtend s-          -- ^ Any configuration options which override the defaults-          -> Initializer s-          -- ^ The 'Initializer' function for the application's monad-          -> SnapExtend s ()-          -- ^ The application to be served-          -> IO ()-httpServe config initializer handler = do-    (snap, cleanup) <- runInitializerWithReloadAction-                         verbose-                         initializer-                         (catch500 handler)-                         reloader-    let site = compress $ snap-    mapM_ printListen $ C.getListen config-    _   <- try $ serve $ site :: IO (Either SomeException ())-    putStr "\n"-    cleanup-    output "Shutting down..."--  where-    conf     = completeConfig config-    verbose  = fromJust $ getVerbose conf-    output   = when verbose . hPutStrLn stderr-    reloader = fromJust $ getReloadHandler conf-    compress = if fromJust $ getCompression conf then withCompression else id-    catch500 = flip catch $ fromJust $ getErrorHandler conf-    serve    = simpleHttpServe config--    listenToString (C.ListenHttp host port) =-        concat ["http://", fromUTF8 host, ":", show port, "/"]-    listenToString (C.ListenHttps host port _ _) =-        concat ["https://", fromUTF8 host, ":", show port, "/"]--    printListen l = output $ "Listening on " ++ listenToString l------------------------------------------------------------------------------------ | Starts serving HTTP using the given handler. The configuration is read--- from the options given on the command-line, as returned by--- 'commandLineConfig'.-quickHttpServe :: Initializer s-               -- ^ The 'Initializer' function for the application's monad-               -> SnapExtend s ()-               -- ^ The application to be served-               -> IO ()-quickHttpServe r m = commandLineConfig emptyConfig >>= \c -> httpServe c r m---------------------------------------------------------------------------------fromUTF8 :: ByteString -> String-fromUTF8 = T.unpack . T.decodeUtf8
+ src/Snap/Snaplet.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE Rank2Types                 #-}+{-# LANGUAGE TypeOperators              #-}++{-|++Snaplets allow you to build web applications out of composable parts. This+allows you to build self-contained units and glue them together to make your+overall application.++A snaplet has a few moving parts, some user-defined and some provided by the+snaplet API:++  * each snaplet has its own configuration given to it at startup.++  * each snaplet is given its own directory on the filesystem, from which it+    reads its configuration and in which it can store files.++  * each snaplet comes with an 'Initializer' which defines how to create an+    instance of the Snaplet at startup. The initializer decides how to+    interpret the snaplet configuration, which URLs to handle (and how), sets+    up the initial snaplet state, tells the snaplet runtime system how to+    clean the snaplet up, etc.++  * each snaplet contains some user-defined in-memory state; for instance, a+    snaplet that talks to a database might contain a reference to a connection+    pool. The snaplet state is an ordinary Haskell record, with a datatype+    defined by the snaplet author. The initial state record is created during+    initialization and is available to snaplet 'Handler's when serving HTTP+    requests.++NOTE: This documentation is written as a prose tutorial of the snaplets+API.  Don't be scared by the fact that it's auto-generated and is filled with+type signatures.  Just keep reading.++-}++module Snap.Snaplet+  (+  -- * Snaplet+  -- $snapletDoc+    Snaplet+  , SnapletConfig++  -- * Lenses+  -- $lenses++  -- * Snaplet Helper Functions+  -- $snapletHelpers+  , snapletConfig+  , snapletValue+  , subSnaplet++  -- * MonadSnaplet+  -- $monadSnaplet+  , MonadSnaplet(..)+  , getSnapletAncestry+  , getSnapletFilePath+  , getSnapletName+  , getSnapletDescription+  , getSnapletUserConfig+  , getSnapletRootURL+  , snapletURL+  , getRoutePattern+  , setRoutePattern++  -- * Snaplet state manipulation+  -- $snapletState+  , getSnapletState+  , putSnapletState+  , modifySnapletState+  , getsSnapletState++--  , wrap+--  , wrapTop++  -- * Initializer+  -- $initializer+  , Initializer+  , SnapletInit+  , makeSnaplet++  , nestSnaplet+  , embedSnaplet+  , nameSnaplet++  , onUnload+  , addPostInitHook+  , addPostInitHookBase+  , printInfo+  , getRoutes+  , getEnvironment++  -- * Routes+  -- $routes+  , addRoutes+  , wrapSite++  -- * Handlers+  , Handler+  , failIfNotLocal+  , reloadSite+  , modifyMaster+  , bracketHandler++  -- * Serving Applications+  , runSnaplet+  , combineConfig+  , serveSnaplet+  , serveSnapletNoArgParsing+  , loadAppConfig++  -- * Snaplet Lenses+  , SnapletLens+  ) where+++import           Snap.Snaplet.Internal.Initializer+import           Snap.Snaplet.Internal.Types++-- $snapletDoc+-- The heart of the snaplets infrastructure is state management. (Note: when+-- we say \"state\" here, we mean in-memory Haskell objects, not external data+-- storage or databases; how you deal with persisted data is up to you.) Most+-- nontrivial pieces of a web application need some kind of runtime state or+-- environment data. The datatype we use to handle this is called 'Snaplet':++-- $snapletHelpers+--+-- Your web application will itself get wrapped in a 'Snaplet', and the+-- top-level user state of your application (which will likely contain other+-- snaplets nested inside it) will look something like this:+--+-- > data App = App+-- >     { _foo                :: Snaplet Foo+-- >     , _bar                :: Snaplet Bar+-- >     , _someNonSnapletData :: String+-- >     }+--+-- Every web application using snaplets has a top-most user state which+-- contains all of the application state; we call this state the \"base\"+-- state.+--+-- We export several helper lenses for working with Snaplet types.++-- $lenses+-- In the example above, the @Foo@ snaplet has to be written to work with any+-- base state (otherwise it wouldn't be reusable!), but functions written to+-- work with the @Foo@ snaplet want to be able to modify the @Foo@ record+-- /within the context/ of the base state. Given that Haskell datatypes are+-- pure, how do you allow for this?+--+-- Our solution is to use /lenses/, as defined in Edward Kmett's @lens@+-- library (<http://hackage.haskell.org/package/lens>). A lens, notated+-- as follows:+--+-- > SimpleLens a b+--+-- is conceptually a \"getter\" and a \"setter\" rolled up into one. The+-- @lens@ library provides the following functions:+--+-- > view :: (SimpleLens a b) -> a -> b+-- > set  :: (SimpleLens a b) -> b -> a -> a+-- > over :: (SimpleLens a b) -> (b -> b) -> a -> a+--+-- which allow you to get, set, and modify a value of type @b@ within the+-- context of type @a@. The @lens@ package comes with a Template Haskell+-- function called 'makeLenses', which auto-magically defines a lens for every+-- record field having a name beginning with an underscore. In the @App@+-- example above, adding the declaration:+--+-- > makeLenses ''App+--+-- would define lenses:+--+-- > foo                :: SimpleLens App (Snaplet Foo)+-- > bar                :: SimpleLens App (Snaplet Bar)+-- > someNonSnapletData :: SimpleLens App String+--+-- The coolest thing about @lens@ lenses is that they /compose/ using the+-- @(.)@ operator. If the @Foo@ type had a field of type @Quux@ within it with+-- a lens @quux :: SimpleLens Foo Quux@, then you could create a lens of type+-- @SimpleLens App Quux@ by composition:+--+-- > import Control.Lens+-- >+-- > data Foo = Foo { _quux :: Quux }+-- > makeLenses ''Foo+-- >+-- > -- snapletValue is defined in the framework:+-- > snapletValue :: SimpleLens (Snaplet a) a+-- >+-- > appQuuxLens :: SimpleLens App Quux+-- > appQuuxLens = foo . snapletValue . quux+--+-- Lens composition is very similar to function composition except it works in+-- the opposite direction (think Java-style System.out.println ordering) and+-- it gives you a composed getter and setter at the same time.++-- $monadSnaplet+-- The primary abstraction in the snaplet infrastructure is a combination of+-- the reader and state monads.  The state monad holds the top level+-- application data type (from now on referred to as the base state).  The+-- reader monad holds a lens from the base state to the current snaplet's+-- state.  This allows quux snaplet functions to access and modify the Quux+-- data structure without knowing anything about the App or Foo data+-- structures. It also lets other snaplets call functions from the quux+-- snaplet if they have the quux snaplet's lens @SimpleLens App (Snaplet Quux)@.+-- We can view our application as a tree of snaplets and other pieces of data.+-- The lenses are like pointers to nodes of the tree. If you have a pointer to+-- a node, you can access the node and all of its children without knowing+-- anything about the rest of the tree.+--+-- Several monads use this infrastructure. These monads need at least three+-- type parameters. Two for the lens type, and the standard \'a\' denoting the+-- monad return value. You will usually see this written in type signatures as+-- \"m b v a\" or some variation. The \'m\' is the type variable of the+-- MonadSnaplet type class. \'b\' is the base state, and \'v\' is the state of+-- the current \"view\" snaplet (or simply, current state).+--+-- The MonadSnaplet type class distills the essence of the operations used+-- with this pattern.  Its functions define fundamental methods for navigating+-- snaplet trees.++-- $snapletState+-- MonadSnaplet instances will typically have @MonadState v@ instances.  We+-- provide the following convenience functions which give the equivalent to+-- @MonadState (Snaplet v)@ for the less common cases where you need to work+-- with the Snaplet wrapper.++-- $initializer+-- The Initializer monad is where your application's initialization happens.+-- Initializers are run at startup and any time a site reload is triggered.+-- The Initializer's job is to construct a snaplet's routes and initial state,+-- set up filesystem data, read config files, etc.+--+-- In order to initialize its state, a snaplet needs to initialize all the+-- @Snaplet a@ state for each of its subsnaplets.  The only way to construct+-- a @Snaplet a@ type is by calling 'nestSnaplet' or 'embedSnaplet' from+-- within an initializer.+++-- $writingSnaplets+-- When writing a snaplet, you must define an initializer function.  The+-- initializer function for the Foo snaplet (where Foo is the snaplet's+-- state type) must have a return type of @Initializer b Foo Foo@.+-- To create an initializer like this, you have to use the 'makeSnaplet'+-- function.  It takes care of the necessary internal bookkeeping needed when+-- initializing a new snaplet.  Haskell's strong type system allows us to+-- ensure that calling 'makeSnaplet' is the only way you can construct a+-- Snaplet type.+++-- $routes+-- Snaplet initializers are also responsible for setting up any routes defined+-- by the snaplet.  To do that you'll usually use either 'addRoutes' or+-- 'wrapSite'.+++{-+++/FIXME/: finish this section+++Discuss:++  * lenses and how snaplet apps are built out of parts.++  * the initializer type, and what you can do with it++  * layout of snaplets on disk, and how on-disk stuff can be auto-populated+    from the cabal data directory++  * the handler type, and what you can do with it+++++{FIXME: strike/rewrite these sentences. Components that do not need any kind+of state or environment are probably more appropriate as a standalone+library than as a snaplet.++We start our application by defining a data structure to hold the state.+This data structure includes the state of any snaplets (wrapped in a+Snaplet) we want to use as well as any other state we might want.}++> module MyApp where+> import Control.Lens+> import Snap.Snaplet+> import Snap.Snaplet.Heist+>+> data App = App+>     { _heist       :: Snaplet (Heist App)+>     , _foo         :: Snaplet Foo+>     , _bar         :: Snaplet Bar+>     , _companyName :: String+>     }+>+> makeLenses ''App++The next thing we need to do is define an initializer.++> app :: Initializer App App App+> app = do+>     hs <- nestSnaplet "heist" $ heistInit "templates"+>     fs <- nestSnaplet "foo" $ fooInit heist+>     bs <- nestSnaplet "" $ nameSnaplet "baz" $ barInit heist+>     addRoutes [ ("/hello", writeText "hello world")+>               ]+>     wrapSite (<|> with heist heistServe)+>     return $ App hs fs bs "fooCorp"++Then we define a simple main to run the application.++> main = serveSnaplet defaultConfig app++++Snaplet filesystem directory structure:++> snaplet+>   |-- snaplet.cabal+>   |-- log/+>   |-- src/+> ------------------------+>   |-- db.cfg+>   |-- snaplet.cfg+>   |-- public/+>       |-- stylesheets/+>       |-- images/+>       |-- js/+>   |-- snaplets+>       |-- subsnaplet1/+>       |-- subsnaplet2/+>   |-- templates/++-}+
+ src/Snap/Snaplet/Auth.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings         #-}++------------------------------------------------------------------------------+-- |+--+-- This module contains all the central authentication functionality.+--+-- It exports a number of high-level functions to be used directly in your+-- application handlers.+--+-- We also export a number of mid-level functions that should be helpful when+-- you are integrating with another way of confirming the authentication of+-- login requests.+--++module Snap.Snaplet.Auth+  (+  -- * Higher Level Handler Functions+    createUser+  , usernameExists+  , saveUser+  , destroyUser+  , loginByUsername+  , loginByRememberToken+  , forceLogin+  , logout+  , currentUser+  , isLoggedIn++  -- * Lower Level Functions+  , markAuthSuccess+  , markAuthFail+  , checkPasswordAndLogin++  -- * Types+  , AuthManager(..)+  , IAuthBackend(..)+  , AuthSettings(..)+  , defAuthSettings+  , AuthUser(..)+  , defAuthUser+  , UserId(..)+  , Password(..)+  , AuthFailure(..)+  , Role(..)++  -- * Other Utilities+  , authSettingsFromConfig+  , withBackend+  , encryptPassword+  , checkPassword+  , authenticatePassword+  , setPassword+  , encrypt+  , verify++  -- * Handlers+  , registerUser+  , loginUser+  , logoutUser+  , requireUser+  , setPasswordResetToken+  , clearPasswordResetToken++  -- * Splice helpers+  , addAuthSplices+  , compiledAuthSplices+  , userCSplices+  , userISplices+  , ifLoggedIn+  , ifLoggedOut+  , loggedInUser+  )+  where++------------------------------------------------------------------------------+import Snap.Snaplet.Auth.AuthManager+import Snap.Snaplet.Auth.Handlers+import Snap.Snaplet.Auth.SpliceHelpers+import Snap.Snaplet.Auth.Types+
+ src/Snap/Snaplet/Auth/AuthManager.hs view
@@ -0,0 +1,107 @@+------------------------------------------------------------------------------+-- | Internal module exporting AuthManager implementation.+--+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}++module Snap.Snaplet.Auth.AuthManager+  ( -- * AuthManager Datatype+    AuthManager(..)++    -- * Backend Typeclass+    , IAuthBackend(..)++    -- * Context-free Operations+    , buildAuthUser+  ) where++------------------------------------------------------------------------------+import           Data.ByteString (ByteString)+import           Data.Text (Text)+import           Data.Time+import           Web.ClientSession++import           Snap.Snaplet+import           Snap.Snaplet.Session+import           Snap.Snaplet.Auth.Types+++------------------------------------------------------------------------------+-- | Creates a new user from a username and password.+--+buildAuthUser :: IAuthBackend r =>+                 r            -- ^ An auth backend+              -> Text         -- ^ Username+              -> ByteString   -- ^ Password+              -> IO (Either AuthFailure AuthUser)+buildAuthUser r unm pass = do+  now <- getCurrentTime+  let au = defAuthUser {+              userLogin     = unm+            , userPassword  = Nothing+            , userCreatedAt = Just now+            , userUpdatedAt = Just now+            }+  au' <- setPassword au pass+  save r au'+++------------------------------------------------------------------------------+-- | All storage backends need to implement this typeclass+--+class IAuthBackend r where+  -- | Create or update the given 'AuthUser' record.  A 'userId' of Nothing+  -- indicates that a new user should be created, otherwise the user+  -- information for that userId should be updated.+  save                  :: r -> AuthUser -> IO (Either AuthFailure AuthUser)+  lookupByUserId        :: r -> UserId   -> IO (Maybe AuthUser)+  lookupByLogin         :: r -> Text     -> IO (Maybe AuthUser)+  lookupByEmail         :: r -> Text     -> IO (Maybe AuthUser)+  lookupByRememberToken :: r -> Text     -> IO (Maybe AuthUser)+  destroy               :: r -> AuthUser -> IO ()+++------------------------------------------------------------------------------+-- | Abstract data type holding all necessary information for auth operation+data AuthManager b = forall r. IAuthBackend r => AuthManager {+      backend               :: r+        -- ^ Storage back-end++    , session               :: SnapletLens b SessionManager+        -- ^ A lens pointer to a SessionManager++    , activeUser            :: Maybe AuthUser+        -- ^ A per-request logged-in user cache++    , minPasswdLen          :: Int+        -- ^ Password length range++    , rememberCookieName    :: ByteString+        -- ^ Cookie name for the remember token++    , rememberCookieDomain  :: Maybe ByteString+        -- ^ Domain for which remember cookie will be created.++    , rememberPeriod        :: Maybe Int+        -- ^ Remember period in seconds. Defaults to 2 weeks.++    , siteKey               :: Key+        -- ^ A unique encryption key used to encrypt remember cookie++    , lockout               :: Maybe (Int, NominalDiffTime)+        -- ^ Lockout after x tries, re-allow entry after y seconds++    , randomNumberGenerator :: RNG+        -- ^ Random number generator+    }++instance IAuthBackend (AuthManager b) where+    save AuthManager{..} u = save backend u+    lookupByUserId AuthManager{..} u = lookupByUserId backend u+    lookupByLogin AuthManager{..} u = lookupByLogin backend u+    lookupByEmail AuthManager{..}  u = lookupByEmail backend u+    lookupByRememberToken AuthManager{..} u = lookupByRememberToken backend u+    destroy AuthManager{..} u = destroy backend u
+ src/Snap/Snaplet/Auth/Backends/JsonFile.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Snap.Snaplet.Auth.Backends.JsonFile+  ( initJsonFileAuthManager+  , mkJsonAuthMgr+  ) where+++import           Control.Applicative ((<|>))+import           Control.Monad (join)+import           Control.Monad.State+import           Control.Concurrent.STM+import           Data.Aeson+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, listToMaybe)+import           Data.Monoid (mempty)+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Time+import           Web.ClientSession+import           System.Directory++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif++import           Snap.Snaplet+import           Snap.Snaplet.Auth.Types+import           Snap.Snaplet.Auth.AuthManager+import           Snap.Snaplet.Session++++------------------------------------------------------------------------------+-- | Initialize a JSON file backed 'AuthManager'+initJsonFileAuthManager :: AuthSettings+                            -- ^ Authentication settings for your app+                        -> SnapletLens b SessionManager+                            -- ^ Lens into a 'SessionManager' auth snaplet will+                           -- use+                        -> FilePath+                            -- ^ Where to store user data as JSON+                        -> SnapletInit b (AuthManager b)+initJsonFileAuthManager s l db = do+    makeSnaplet+        "JsonFileAuthManager"+        "A snaplet providing user authentication using a JSON-file backend"+        Nothing $ liftIO $ do+            rng <- liftIO mkRNG+            key <- getKey (asSiteKey s)+            jsonMgr <- mkJsonAuthMgr db+            return $! AuthManager {+                         backend               = jsonMgr+                       , session               = l+                       , activeUser            = Nothing+                       , minPasswdLen          = asMinPasswdLen s+                       , rememberCookieName    = asRememberCookieName s+                       , rememberCookieDomain  = Nothing+                       , rememberPeriod        = asRememberPeriod s+                       , siteKey               = key+                       , lockout               = asLockout s+                       , randomNumberGenerator = rng+                       }+++------------------------------------------------------------------------------+-- | Load/create a datafile into memory cache and return the manager.+--+-- This data type can be used by itself for batch/non-handler processing.+mkJsonAuthMgr :: FilePath -> IO JsonFileAuthManager+mkJsonAuthMgr fp = do+  db <- loadUserCache fp+  let db' = case db of+              Left e  -> error e+              Right x -> x+  cache <- newTVarIO db'++  return $! JsonFileAuthManager {+      memcache = cache+    , dbfile   = fp+  }+++------------------------------------------------------------------------------+type UserIdCache = Map UserId AuthUser++#if !MIN_VERSION_aeson(1,0,0)+-- In aeson >= 1 these instances are not needed because we have+-- derived ToJSONKey/FromJSONKey instances for UserId.+instance ToJSON UserIdCache where+  toJSON m = toJSON $ HM.toList m++instance FromJSON UserIdCache where+  parseJSON = fmap HM.fromList . parseJSON+#endif++------------------------------------------------------------------------------+type LoginUserCache = Map Text UserId+++------------------------------------------------------------------------------+type EmailUserCache = Map Text UserId+++------------------------------------------------------------------------------+type RemTokenUserCache = Map Text UserId+++------------------------------------------------------------------------------+-- | JSON user back-end stores the user data and indexes for login and token+-- based logins.+data UserCache = UserCache {+    uidCache    :: UserIdCache          -- ^ the actual datastore+  , loginCache  :: LoginUserCache       -- ^ fast lookup for login field+  , emailCache  :: EmailUserCache       -- ^ fast lookup for email field+  , tokenCache  :: RemTokenUserCache    -- ^ fast lookup for remember tokens+  , uidCounter  :: Int                  -- ^ user id counter+}+++------------------------------------------------------------------------------+defUserCache :: UserCache+defUserCache = UserCache {+    uidCache   = HM.empty+  , loginCache = HM.empty+  , emailCache = HM.empty+  , tokenCache = HM.empty+  , uidCounter = 0+}+++------------------------------------------------------------------------------+loadUserCache :: FilePath -> IO (Either String UserCache)+loadUserCache fp = do+  chk <- doesFileExist fp+  case chk of+    True -> do+      d <- B.readFile fp+      case Atto.parseOnly json d of+        Left e  -> return $! Left $+                       "Can't open JSON auth backend. Error: " ++ e+        Right v -> case fromJSON v of+          Error e    -> return $! Left $+                        "Malformed JSON auth data store. Error: " ++ e+          Success db -> return $! Right db+    False -> do+      putStrLn "User JSON datafile not found. Creating a new one."+      return $ Right defUserCache+++------------------------------------------------------------------------------+data JsonFileAuthManager = JsonFileAuthManager {+    memcache :: TVar UserCache+  , dbfile   :: FilePath+}+++------------------------------------------------------------------------------+jsonFileSave :: JsonFileAuthManager+             -> AuthUser+             -> IO (Either AuthFailure AuthUser)+jsonFileSave mgr u = do+    now        <- getCurrentTime+    oldByLogin <- lookupByLogin mgr (userLogin u)+    oldById    <- case userId u of+                    Nothing -> return Nothing+                    Just x  -> lookupByUserId mgr x++    res <- atomically $ do+      cache <- readTVar (memcache mgr)+      res   <- case userId u of+                 Nothing -> create cache now oldByLogin+                 Just _  -> update cache now oldById+      case res of+        Left e             -> return $! Left e+        Right (cache', u') -> do+          writeTVar (memcache mgr) cache'+          return $! Right $! (cache', u')++    case res of+      Left _             -> return $! Left BackendError+      Right (cache', u') -> do+        dumpToDisk cache'+        return $! Right u'++  where+    --------------------------------------------------------------------------+    create :: UserCache+           -> UTCTime+           -> (Maybe AuthUser)+           -> STM (Either AuthFailure (UserCache, AuthUser))+    create cache now old = do+      case old of+        Just _  -> return $! Left DuplicateLogin+        Nothing -> do+          new <- do+            let uid' = UserId . showT $ uidCounter cache + 1+            let u'   = u { userUpdatedAt = Just now, userId = Just uid' }+            return $! cache {+              uidCache   = HM.insert uid' u' $ uidCache cache+            , loginCache = HM.insert (userLogin u') uid' $ loginCache cache+            , emailCache = maybe id (\em -> HM.insert em uid') (userEmail u) $+                           emailCache cache+            , tokenCache = case userRememberToken u' of+                             Nothing -> tokenCache cache+                             Just x  -> HM.insert x uid' $ tokenCache cache+            , uidCounter = uidCounter cache + 1+            }+          return $! Right (new, getLastUser new)++    --------------------------------------------------------------------------+    -- lookup old record, see what's changed and update indexes accordingly+    update :: UserCache+           -> UTCTime+           -> (Maybe AuthUser)+           -> STM (Either AuthFailure (UserCache, AuthUser))+    update cache now old =+      case old of+        Nothing -> return $! Left UserNotFound+        Just x -> do+          let oldLogin = userLogin x+          let oldEmail = userEmail x+          let oldToken = userRememberToken x+          let uid      = fromJust $ userId u+          let newLogin = userLogin u+          let newEmail = userEmail u+          let newToken = userRememberToken u++          let lc       = if oldLogin /= userLogin u+                           then HM.insert newLogin uid $+                                HM.delete oldLogin $+                                loginCache cache+                           else loginCache cache++          let ec       = if oldEmail /= newEmail+                           then (case (oldEmail, newEmail) of+                                   (Nothing, Nothing) -> id+                                   (Just e,  Nothing) -> HM.delete e+                                   (Nothing, Just e ) -> HM.insert e uid+                                   (Just e,  Just e') -> HM.insert e' uid .+                                                         HM.delete e+                                ) (emailCache cache)+                           else emailCache cache++          let tc       = if oldToken /= newToken && isJust oldToken+                           then HM.delete (fromJust oldToken) $ loginCache cache+                           else tokenCache cache++          let tc'      = case newToken of+                           Just t  -> HM.insert t uid tc+                           Nothing -> tc++          let u'       = u { userUpdatedAt = Just now }++          let new      = cache {+                             uidCache   = HM.insert uid u' $ uidCache cache+                           , loginCache = lc+                           , emailCache = ec+                           , tokenCache = tc'+                         }++          return $! Right (new, u')++    --------------------------------------------------------------------------+    -- Sync user database to disk+    -- Need to implement a mutex here; simult syncs could screw things up+    dumpToDisk c = LB.writeFile (dbfile mgr) (encode c)++    --------------------------------------------------------------------------+    -- Gets the last added user+    getLastUser cache = maybe e id $ getUser cache uid+      where+        uid = UserId . showT $ uidCounter cache+        e   = error "getLastUser failed. This should not happen."+++------------------------------------------------------------------------------+instance IAuthBackend JsonFileAuthManager where+  save = jsonFileSave++  destroy = error "JsonFile: destroy is not yet implemented"++  lookupByUserId mgr uid = withCache mgr f+    where+      f cache = getUser cache uid++  lookupByLogin mgr login = withCache mgr f+    where+      f cache = getUid >>= getUser cache+        where getUid = HM.lookup login (loginCache cache)++  lookupByEmail mgr email = withCache mgr f+    where+      f cache = getEmail >>= getUser cache+        where getEmail = case HM.lookup email (emailCache cache) of+                      Just u  -> return u+                      Nothing -> (join . fmap userId .+                                  listToMaybe . HM.elems $+                                  HM.filter ((== Just email) . userEmail)+                                  (uidCache  cache))++  lookupByRememberToken mgr token = withCache mgr f+    where+      f cache = getUid >>= getUser cache+        where+          getUid = HM.lookup token (tokenCache cache)+++------------------------------------------------------------------------------+withCache :: JsonFileAuthManager -> (UserCache -> a) -> IO a+withCache mgr f = atomically $ do+  cache <- readTVar $ memcache mgr+  return $! f cache+++------------------------------------------------------------------------------+getUser :: UserCache -> UserId -> Maybe AuthUser+getUser cache uid = HM.lookup uid (uidCache cache)+++------------------------------------------------------------------------------+showT :: Int -> Text+showT = T.pack . show+++                             --------------------+                             -- JSON Instances --+                             --------------------++------------------------------------------------------------------------------+instance ToJSON UserCache where+  toJSON uc = object+    [ "uidCache"   .= uidCache   uc+    , "loginCache" .= loginCache uc+    , "emailCache" .= emailCache uc+    , "tokenCache" .= tokenCache uc+    , "uidCounter" .= uidCounter uc+    ]+++------------------------------------------------------------------------------+instance FromJSON UserCache where+  parseJSON (Object v) =+    UserCache+      <$> v .: "uidCache"+      <*> v .: "loginCache"+      <*> (v .: "emailCache" <|> pure mempty) -- Old versions of users.json do+                                              -- not carry this field+      <*> v .: "tokenCache"+      <*> v .: "uidCounter"+  parseJSON _ = error "Unexpected JSON input"
+ src/Snap/Snaplet/Auth/Handlers.hs view
@@ -0,0 +1,546 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE Rank2Types                #-}++------------------------------------------------------------------------------+-- | Pre-packaged Handlers that deal with form submissions and standard+--   use-cases involving authentication.++module Snap.Snaplet.Auth.Handlers where++------------------------------------------------------------------------------+import           Control.Applicative+import           Control.Monad (join, liftM, liftM2)+import           Control.Monad.State+import           Control.Monad.Trans.Maybe+import           Data.ByteString (ByteString)+import           Data.Maybe+import           Data.Serialize hiding (get)+import           Data.Time+import           Data.Text.Encoding (decodeUtf8)+import           Data.Text (Text, null, strip)+import           Prelude hiding (null)+import           Web.ClientSession+------------------------------------------------------------------------------+import           Snap.Core+import           Snap.Snaplet+import           Snap.Snaplet.Auth.AuthManager+import           Snap.Snaplet.Auth.Types+import           Snap.Snaplet.Session+------------------------------------------------------------------------------+++                         ----------------------------+                         -- Higher level functions --+                         ----------------------------++------------------------------------------------------------------------------+-- | Create a new user from just a username and password+--+createUser :: Text              -- ^ Username+           -> ByteString        -- ^ Password+           -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+createUser unm pwd+  | null $ strip unm = return $ Left UsernameMissing+  | otherwise = do+     uExists <- usernameExists unm+     if uExists then return $ Left DuplicateLogin+                else withBackend $ \r -> liftIO $ buildAuthUser r unm pwd+++------------------------------------------------------------------------------+-- | Check whether a user with the given username exists.+--+usernameExists :: Text          -- ^ The username to be checked+               -> Handler b (AuthManager b) Bool+usernameExists username =+    withBackend $ \r -> liftIO $ isJust <$> lookupByLogin r username+++------------------------------------------------------------------------------+-- | Lookup a user by her username, check given password and perform login+--+loginByUsername :: Text             -- ^ Username/login for user+                -> Password         -- ^ Should be ClearText+                -> Bool             -- ^ Set remember token?+                -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+loginByUsername _ (Encrypted _) _ = return $ Left EncryptedPassword+loginByUsername unm pwd shouldRemember = do+    sk <- gets siteKey+    cn <- gets rememberCookieName+    cd <- gets rememberCookieDomain+    rp <- gets rememberPeriod+    withBackend $ loginByUsername' sk cn cd rp++  where+    --------------------------------------------------------------------------+    loginByUsername' :: (IAuthBackend t) =>+                        Key+                     -> ByteString+                     -> Maybe ByteString+                     -> Maybe Int+                     -> t+                     -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+    loginByUsername' sk cn cd rp r =+        liftIO (lookupByLogin r unm) >>=+        maybe (return $! Left UserNotFound) found++      where+        ----------------------------------------------------------------------+        found user = checkPasswordAndLogin user pwd >>=+                     either (return . Left) matched++        ----------------------------------------------------------------------+        matched user+            | shouldRemember = do+                  token <- gets randomNumberGenerator >>=+                           liftIO . randomToken 64++                  setRememberToken sk cn cd rp token++                  let user' = user {+                                userRememberToken = Just (decodeUtf8 token)+                              }++                  saveUser user'+                  return $! Right user'++            | otherwise = return $ Right user+++------------------------------------------------------------------------------+-- | Remember user from the remember token if possible and perform login+--+loginByRememberToken :: Handler b (AuthManager b) (Either AuthFailure AuthUser)+loginByRememberToken = withBackend $ \impl -> do+    key         <- gets siteKey+    cookieName_ <- gets rememberCookieName+    period      <- gets rememberPeriod++    res <- runMaybeT $ do+        token <- MaybeT $ getRememberToken key cookieName_ period+        MaybeT $ liftIO $ lookupByRememberToken impl $ decodeUtf8 token+    case res of+      Nothing -> return $ Left $ AuthError+                   "loginByRememberToken: no remember token"+      Just user -> do+        forceLogin user+        return $ Right user+++------------------------------------------------------------------------------+-- | Logout the active user+--+logout :: Handler b (AuthManager b) ()+logout = do+    s <- gets session+    withTop s $ withSession s removeSessionUserId+    rc <- gets rememberCookieName+    rd <- gets rememberCookieDomain+    expireSecureCookie rc rd+    modify $ \mgr -> mgr { activeUser = Nothing }+++------------------------------------------------------------------------------+-- | Return the current user; trying to remember from cookie if possible.+--+currentUser :: Handler b (AuthManager b) (Maybe AuthUser)+currentUser = cacheOrLookup $ withBackend $ \r -> do+    s   <- gets session+    uid <- withTop s getSessionUserId+    case uid of+      Nothing -> either (const Nothing) Just <$> loginByRememberToken+      Just uid' -> liftIO $ lookupByUserId r uid'+++------------------------------------------------------------------------------+-- | Convenience wrapper around 'rememberUser' that returns a bool result+--+isLoggedIn :: Handler b (AuthManager b) Bool+isLoggedIn = isJust <$> currentUser+++------------------------------------------------------------------------------+-- | Create or update a given user+--+saveUser :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+saveUser u+    | null $ userLogin u = return $ Left UsernameMissing+    | otherwise = withBackend $ \r -> liftIO $ save r u+++------------------------------------------------------------------------------+-- | Destroy the given user+--+destroyUser :: AuthUser -> Handler b (AuthManager b) ()+destroyUser u = withBackend $ liftIO . flip destroy u+++                      -----------------------------------+                      --  Lower level helper functions --+                      -----------------------------------++------------------------------------------------------------------------------+-- | Mutate an 'AuthUser', marking failed authentication+--+-- This will save the user to the backend.+--+markAuthFail :: AuthUser+             -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+markAuthFail u = withBackend $ \r -> do+    lo <- gets lockout+    incFailCtr u >>= checkLockout lo >>= liftIO . save r++  where+    --------------------------------------------------------------------------+    incFailCtr u' = return $ u' {+                      userFailedLoginCount = userFailedLoginCount u' + 1+                    }++    --------------------------------------------------------------------------+    checkLockout lo u' =+        case lo of+          Nothing          -> return u'+          Just (mx, wait)  ->+              if userFailedLoginCount u' >= mx+                then do+                  now <- liftIO getCurrentTime+                  let reopen = addUTCTime wait now+                  return $! u' { userLockedOutUntil = Just reopen }+                else return u'+++------------------------------------------------------------------------------+-- | Mutate an 'AuthUser', marking successful authentication+--+-- This will save the user to the backend.+--+markAuthSuccess :: AuthUser+                -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+markAuthSuccess u = withBackend $ \r ->+                        incLoginCtr u     >>=+                        updateIp          >>=+                        updateLoginTS     >>=+                        resetFailCtr      >>=+                        liftIO . save r+  where+    --------------------------------------------------------------------------+    incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }++    --------------------------------------------------------------------------+    updateIp u' = do+        ip <- rqClientAddr <$> getRequest+        return $ u' { userLastLoginIp = userCurrentLoginIp u'+                    , userCurrentLoginIp = Just ip }++    --------------------------------------------------------------------------+    updateLoginTS u' = do+        now <- liftIO getCurrentTime+        return $+          u' { userCurrentLoginAt = Just now+             , userLastLoginAt = userCurrentLoginAt u' }++    --------------------------------------------------------------------------+    resetFailCtr u' = return $ u' { userFailedLoginCount = 0+                                  , userLockedOutUntil = Nothing }+++------------------------------------------------------------------------------+-- | Authenticate and log the user into the current session if successful.+--+-- This is a mid-level function exposed to allow roll-your-own ways of looking+-- up a user from the database.+--+-- This function will:+--+-- 1. Check the password+--+-- 2. Login the user into the current session+--+-- 3. Mark success/failure of the authentication trial on the user record+--+checkPasswordAndLogin+  :: AuthUser               -- ^ An existing user, somehow looked up from db+  -> Password               -- ^ A ClearText password+  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+checkPasswordAndLogin u pw =+    case userLockedOutUntil u of+      Just x -> do+        now <- liftIO getCurrentTime+        if now > x+          then auth u+          else return . Left $ LockedOut x+      Nothing -> auth u++  where+    auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+    auth user =+      case authenticatePassword user pw of+        Just e -> do+          markAuthFail user+          return $ Left e++        Nothing -> do+          forceLogin user+          modify (\mgr -> mgr { activeUser = Just user })+          markAuthSuccess user+++------------------------------------------------------------------------------+-- | Login and persist the given 'AuthUser' in the active session+--+-- Meant to be used if you have other means of being sure that the person is+-- who she says she is.+--+forceLogin :: AuthUser       -- ^ An existing user, somehow looked up from db+           -> Handler b (AuthManager b) (Either AuthFailure ())+forceLogin u = do+    s <- gets session+    withSession s $+        case userId u of+          Just x -> do+            withTop s (setSessionUserId x)+            return $ Right ()+          Nothing -> return . Left $+                     AuthError $ "forceLogin: Can't force the login of a user "+                                   ++ "without userId"+++                     ------------------------------------+                     -- Internal, non-exported helpers --+                     ------------------------------------+++------------------------------------------------------------------------------+getRememberToken :: (Serialize t, MonadSnap m)+                 => Key+                 -> ByteString+                 -> Maybe Int+                 -> m (Maybe t)+getRememberToken sk rc rp = getSecureCookie rc sk rp+++------------------------------------------------------------------------------+setRememberToken :: (Serialize t, MonadSnap m)+                 => Key+                 -> ByteString+                 -> Maybe ByteString+                 -> Maybe Int+                 -> t+                 -> m ()+setRememberToken sk rc rd rp token = setSecureCookie rc rd sk rp token+++------------------------------------------------------------------------------+-- | Set the current user's 'UserId' in the active session+--+setSessionUserId :: UserId -> Handler b SessionManager ()+setSessionUserId (UserId t) = setInSession "__user_id" t+++------------------------------------------------------------------------------+-- | Remove 'UserId' from active session, effectively logging the user out.+removeSessionUserId :: Handler b SessionManager ()+removeSessionUserId = deleteFromSession "__user_id"+++------------------------------------------------------------------------------+-- | Get the current user's 'UserId' from the active session+--+getSessionUserId :: Handler b SessionManager (Maybe UserId)+getSessionUserId = do+  uid <- getFromSession "__user_id"+  return $ liftM UserId uid+++------------------------------------------------------------------------------+-- | Check password for a given user.+--+-- Returns "Nothing" if check is successful and an "IncorrectPassword" error+-- otherwise+--+authenticatePassword :: AuthUser        -- ^ Looked up from the back-end+                     -> Password        -- ^ Check against this password+                     -> Maybe AuthFailure+authenticatePassword u pw = auth+  where+    auth    = case userPassword u of+                Nothing -> Just PasswordMissing+                Just upw -> check $ checkPassword pw upw++    check b = if b then Nothing else Just IncorrectPassword+++------------------------------------------------------------------------------+-- | Wrap lookups around request-local cache+--+cacheOrLookup+  :: Handler b (AuthManager b) (Maybe AuthUser)+      -- ^ Lookup action to perform if request local cache is empty+  -> Handler b (AuthManager b) (Maybe AuthUser)+cacheOrLookup f = do+    au <- gets activeUser+    if isJust au+      then return au+      else do+        au' <- f+        modify (\mgr -> mgr { activeUser = au' })+        return au'+++------------------------------------------------------------------------------+-- | Register a new user by specifying login and password 'Param' fields+--+registerUser+  :: ByteString            -- ^ Login field+  -> ByteString            -- ^ Password field+  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+registerUser lf pf = do+    l <- fmap decodeUtf8 <$> getParam lf+    p <- getParam pf++    let l' = maybe (Left UsernameMissing) Right l+    let p' = maybe (Left PasswordMissing) Right p++    -- In case of multiple AuthFailure, the first available one+    -- will be propagated.+    case liftM2 (,) l' p' of+      Left e           -> return $ Left e+      Right (lgn, pwd) -> createUser lgn pwd+++------------------------------------------------------------------------------+-- | A 'MonadSnap' handler that processes a login form.+--+-- The request paremeters are passed to 'performLogin'+--+-- To make your users stay logged in for longer than the session replay+-- prevention timeout, you must pass a field name as the third parameter and+-- that field must be set to a value of \"1\" by the submitting form.  This+-- lets you use a user selectable check box.  Or if you want user remembering+-- always turned on, you can use a hidden form field.+loginUser+  :: ByteString+      -- ^ Username field+  -> ByteString+      -- ^ Password field+  -> Maybe ByteString+      -- ^ Remember field; Nothing if you want no remember function.+  -> (AuthFailure -> Handler b (AuthManager b) ())+      -- ^ Upon failure+  -> Handler b (AuthManager b) ()+      -- ^ Upon success+  -> Handler b (AuthManager b) ()+loginUser unf pwdf remf loginFail loginSucc =+    loginUser' unf pwdf remf >>= either loginFail (const loginSucc)+++------------------------------------------------------------------------------+loginUser' :: ByteString+           -> ByteString+           -> Maybe ByteString+           -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+loginUser' unf pwdf remf = do+    mbUsername <- getParam unf+    mbPassword <- getParam pwdf+    remember   <- liftM (fromMaybe False)+                    (runMaybeT $+                    do field <- MaybeT $ return remf+                       value <- MaybeT $ getParam field+                       return $ value == "1" || value == "on")++    case mbUsername of+      Nothing -> return $ Left UsernameMissing+      Just u -> case mbPassword of+        Nothing -> return $ Left PasswordMissing+        Just p -> loginByUsername (decodeUtf8 u) (ClearText p) remember+++------------------------------------------------------------------------------+-- | Simple handler to log the user out. Deletes user from session.+--+logoutUser :: Handler b (AuthManager b) ()   -- ^ What to do after logging out+           -> Handler b (AuthManager b) ()+logoutUser target = logout >> target+++------------------------------------------------------------------------------+-- | Require that an authenticated 'AuthUser' is present in the current+-- session.+--+-- This function has no DB cost - only checks to see if a user_id is present+-- in the current session.+--+requireUser :: SnapletLens b (AuthManager b)+                -- ^ Lens reference to an "AuthManager"+            -> Handler b v a+                -- ^ Do this if no authenticated user is present.+            -> Handler b v a+                -- ^ Do this if an authenticated user is present.+            -> Handler b v a+requireUser auth bad good = do+    loggedIn <- withTop auth isLoggedIn+    if loggedIn then good else bad+++------------------------------------------------------------------------------+-- | Run a function on the backend, and return the result.+--+-- This uses an existential type so that the backend type doesn't+-- 'escape' AuthManager.  The reason that the type is Handler b+-- (AuthManager v) a and not a is because anything that uses the+-- backend will return an IO something, which you can liftIO, or a+-- Handler b (AuthManager v) a if it uses other handler things.+--+withBackend ::+    (forall r. (IAuthBackend r) => r -> Handler b (AuthManager v) a)+      -- ^ The function to run with the handler.+  -> Handler b (AuthManager v) a+withBackend f = join $ do+  (AuthManager backend_ _ _ _ _ _ _ _ _ _) <- get+  return $ f backend_+++------------------------------------------------------------------------------+-- | This function generates a random password reset token and stores it in+-- the database for the user.  Call this function when a user forgets their+-- password.  Then use the token to autogenerate a link that the user can+-- visit to reset their password.  This function also sets a timestamp so the+-- reset token can be expired.+setPasswordResetToken :: Text -> Handler b (AuthManager b) (Maybe Text)+setPasswordResetToken login = do+  tokBS <- liftIO . randomToken 40 =<< gets randomNumberGenerator+  let token = decodeUtf8 tokBS+  now <- liftIO getCurrentTime+  success <- modPasswordResetToken login (Just token) (Just now)+  return $ if success then Just token else Nothing+++------------------------------------------------------------------------------+-- | Clears a user's password reset token.  Call this when the user+-- successfully changes their password to ensure that the password reset link+-- cannot be used again.+clearPasswordResetToken :: Text -> Handler b (AuthManager b) Bool+clearPasswordResetToken login = modPasswordResetToken login Nothing Nothing+++------------------------------------------------------------------------------+-- | Helper function used for setting and clearing the password reset token+-- and associated timestamp.+modPasswordResetToken :: Text+                      -> Maybe Text+                      -> Maybe UTCTime+                      -> Handler v (AuthManager v) Bool+modPasswordResetToken login token timestamp = do+  res <- runMaybeT $ do+      u <- MaybeT $ withBackend $ \b -> liftIO $ lookupByLogin b login+      lift $ saveUser $ u+        { userResetToken = token+        , userResetRequestedAt = timestamp+        }+      return ()+  return $ maybe False (\_ -> True) res+++
+ src/Snap/Snaplet/Auth/SpliceHelpers.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}++{-|++  Some pre-packaged splices that add convenience to a Heist-enabled+  application.++-}++module Snap.Snaplet.Auth.SpliceHelpers+  ( addAuthSplices+  , compiledAuthSplices+  , userCSplices+  , userISplices+  , ifLoggedIn+  , ifLoggedOut+  , loggedInUser+  , cIfLoggedIn+  , cIfLoggedOut+  , cLoggedInUser+  ) where++------------------------------------------------------------------------------+import           Control.Lens+import           Control.Monad.Trans+import           Data.Map.Syntax ((##), mapV)+import           Data.Maybe+import qualified Data.Text as T+import           Data.Text.Encoding+import qualified Text.XmlHtml as X+import           Heist+import qualified Heist.Interpreted as I+import qualified Heist.Compiled as C+import           Heist.Splices+import           Snap.Snaplet+import           Snap.Snaplet.Auth.AuthManager+import           Snap.Snaplet.Auth.Handlers+import           Snap.Snaplet.Auth.Types+import           Snap.Snaplet.Heist++#if !MIN_VERSION_base(4,8,0)+import           Data.Monoid+#endif++------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Add all standard auth splices to a Heist-enabled application.+--+-- This adds the following splices:+-- \<ifLoggedIn\>+-- \<ifLoggedOut\>+-- \<loggedInUser\>+addAuthSplices+  :: HasHeist b+  => Snaplet (Heist b)+  -> SnapletLens b (AuthManager b)+      -- ^ A lens reference to 'AuthManager'+  -> Initializer b v ()+addAuthSplices h auth = addConfig h sc+  where+    sc = mempty & scInterpretedSplices .~ is+                & scCompiledSplices .~ cs+    is = do+        "ifLoggedIn"   ## ifLoggedIn auth+        "ifLoggedOut"  ## ifLoggedOut auth+        "loggedInUser" ## loggedInUser auth+    cs = compiledAuthSplices auth++++------------------------------------------------------------------------------+-- | List containing compiled splices for ifLoggedIn, ifLoggedOut, and+-- loggedInUser.+compiledAuthSplices :: SnapletLens b (AuthManager b)+                    -> Splices (SnapletCSplice b)+compiledAuthSplices auth = do+    "ifLoggedIn"   ## cIfLoggedIn auth+    "ifLoggedOut"  ## cIfLoggedOut auth+    "loggedInUser" ## cLoggedInUser auth+++------------------------------------------------------------------------------+-- | Function to generate interpreted splices from an AuthUser.+userISplices :: Monad m => AuthUser -> Splices (I.Splice m)+userISplices AuthUser{..} = do+    "userId"          ## I.textSplice $ maybe "-" unUid userId+    "userLogin"       ## I.textSplice userLogin+    "userEmail"       ## I.textSplice $ fromMaybe "-" userEmail+    "userActive"      ## I.textSplice $ T.pack $ show $ isNothing userSuspendedAt+    "userLoginCount"  ## I.textSplice $ T.pack $ show userLoginCount+    "userFailedCount" ## I.textSplice $ T.pack $ show userFailedLoginCount+    "userLoginAt"     ## I.textSplice $ maybe "-" (T.pack . show) userCurrentLoginAt+    "userLastLoginAt" ## I.textSplice $ maybe "-" (T.pack . show) userLastLoginAt+    "userSuspendedAt" ## I.textSplice $ maybe "-" (T.pack . show) userSuspendedAt+    "userLoginIP"     ## I.textSplice $ maybe "-" decodeUtf8 userCurrentLoginIp+    "userLastLoginIP" ## I.textSplice $ maybe "-" decodeUtf8 userLastLoginIp+    "userIfActive"    ## ifISplice $ isNothing userSuspendedAt+    "userIfSuspended" ## ifISplice $ isJust userSuspendedAt+++------------------------------------------------------------------------------+-- | Compiled splices for AuthUser.+userCSplices :: Monad m => Splices (RuntimeSplice m AuthUser -> C.Splice m)+userCSplices = fields `mappend` ifs+  where+    fields = mapV (C.pureSplice . C.textSplice) $ do+        "userId"          ## maybe "-" unUid . userId+        "userLogin"       ## userLogin+        "userEmail"       ## fromMaybe "-" . userEmail+        "userActive"      ## T.pack . show . isNothing . userSuspendedAt+        "userLoginCount"  ## T.pack . show . userLoginCount+        "userFailedCount" ## T.pack . show . userFailedLoginCount+        "userLoginAt"     ## maybe "-" (T.pack . show) . userCurrentLoginAt+        "userLastLoginAt" ## maybe "-" (T.pack . show) . userLastLoginAt+        "userSuspendedAt" ## maybe "-" (T.pack . show) . userSuspendedAt+        "userLoginIP"     ## maybe "-" decodeUtf8 . userCurrentLoginIp+        "userLastLoginIP" ## maybe "-" decodeUtf8 . userLastLoginIp+    ifs = do+        "userIfActive"    ## ifCSplice (isNothing . userSuspendedAt)+        "userIfSuspended" ## ifCSplice (isJust . userSuspendedAt)+++------------------------------------------------------------------------------+-- | A splice that can be used to check for existence of a user. If a user is+-- present, this will run the contents of the node.+--+-- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>+ifLoggedIn :: SnapletLens b (AuthManager b) -> SnapletISplice b+ifLoggedIn auth = do+    chk <- lift $ withTop auth isLoggedIn+    case chk of+      True -> getParamNode >>= return . X.childNodes+      False -> return []+++------------------------------------------------------------------------------+-- | A splice that can be used to check for existence of a user. If a user is+-- present, this will run the contents of the node.+--+-- > <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 :: SnapletLens b (AuthManager b) -> SnapletISplice b+ifLoggedOut auth = do+    chk <- lift $ withTop auth isLoggedIn+    case chk of+      False -> getParamNode >>= return . X.childNodes+      True -> return []+++------------------------------------------------------------------------------+-- | A splice that can be used to check for absence of a user. If a user is+-- not present, this will run the contents of the node.+--+-- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>+cIfLoggedOut :: SnapletLens b (AuthManager b) -> SnapletCSplice b+cIfLoggedOut auth = do+    cs <- C.runChildren+    return $ C.yieldRuntime $ do+        chk <- lift $ withTop auth isLoggedIn+        case chk of+          False -> C.codeGen cs+          True -> mempty+++-------------------------------------------------------------------------------+-- | A splice that will simply print the current user's login, if+-- there is one.+loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b+loggedInUser auth = do+    u <- lift $ withTop auth currentUser+    maybe (return []) (I.textSplice . userLogin) u+++-------------------------------------------------------------------------------+-- | A splice that will simply print the current user's login, if+-- there is one.+cLoggedInUser :: SnapletLens b (AuthManager b) -> SnapletCSplice b+cLoggedInUser auth =+    return $ C.yieldRuntimeText $ do+        u <- lift $ withTop auth currentUser+        return $ maybe "" userLogin u
+ src/Snap/Snaplet/Auth/Types.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE StandaloneDeriving         #-}++module Snap.Snaplet.Auth.Types where++------------------------------------------------------------------------------+import           Control.Arrow+import           Control.Monad.Trans+import           Crypto.PasswordStore+import           Data.Aeson+import           Data.ByteString       (ByteString)+import qualified Data.Configurator as C+import           Data.HashMap.Strict   (HashMap)+import qualified Data.HashMap.Strict   as HM+import           Data.Hashable         (Hashable)+import           Data.Time+import           Data.Text             (Text)+import           Data.Text.Encoding    (decodeUtf8, encodeUtf8)+import           Data.Typeable+import           Snap.Snaplet++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif+++------------------------------------------------------------------------------+-- | Password is clear when supplied by the user and encrypted later when+-- returned from the db.+data Password = ClearText ByteString+              | Encrypted ByteString+  deriving (Read, Show, Ord, Eq)+++------------------------------------------------------------------------------+-- | Default strength level to pass into makePassword.+defaultStrength :: Int+defaultStrength = 12+++-------------------------------------------------------------------------------+-- | The underlying encryption function, in case you need it for+-- external processing.+encrypt :: ByteString -> IO ByteString+encrypt = flip makePassword defaultStrength+++-------------------------------------------------------------------------------+-- | The underlying verify function, in case you need it for external+-- processing.+verify +    :: ByteString               -- ^ Cleartext+    -> ByteString               -- ^ Encrypted reference+    -> Bool+verify = verifyPassword +++------------------------------------------------------------------------------+-- | Turn a 'ClearText' password into an 'Encrypted' password, ready to+-- be stuffed into a database.+encryptPassword :: Password -> IO Password+encryptPassword p@(Encrypted {}) = return p+encryptPassword (ClearText p)    = Encrypted `fmap` encrypt p +++------------------------------------------------------------------------------+checkPassword :: Password -> Password -> Bool+checkPassword (ClearText pw) (Encrypted pw') = verify pw pw'+checkPassword (ClearText pw) (ClearText pw') = pw == pw'+checkPassword (Encrypted pw) (Encrypted pw') = pw == pw'+checkPassword _ _ =+  error "checkPassword failed. Make sure you pass ClearText passwords"+++------------------------------------------------------------------------------+-- | Authentication failures indicate what went wrong during authentication.+-- They may provide useful information to the developer, although it is+-- generally not advisable to show the user the exact details about why login+-- failed.+data AuthFailure = AuthError String+                 | BackendError+                 | DuplicateLogin+                 | EncryptedPassword+                 | IncorrectPassword+                 | LockedOut UTCTime    -- ^ Locked out until given time+                 | PasswordMissing+                 | UsernameMissing+                 | UserNotFound+  deriving (Read, Ord, Eq, Typeable)+++instance Show AuthFailure where+        show (AuthError s) = s+        show (BackendError) = "Failed to store data in the backend."+        show (DuplicateLogin) = "This login already exists in the backend."+        show (EncryptedPassword) = "Cannot login with encrypted password."+        show (IncorrectPassword) = "The password provided was not valid."+        show (LockedOut time) = "The login is locked out until " ++ show time+        show (PasswordMissing) = "No password provided."+        show (UsernameMissing) = "No username provided."+        show (UserNotFound) = "User not found in the backend."+++------------------------------------------------------------------------------+-- | Internal representation of a 'User'. By convention, we demand that the+-- application is able to directly fetch a 'User' using this identifier.+--+-- Think of this type as a secure, authenticated user. You should normally+-- never see this type unless a user has been authenticated.+newtype UserId = UserId { unUid :: Text }+  deriving ( Read, Show, Ord, Eq, FromJSON, ToJSON, Hashable )++#if MIN_VERSION_aeson(1,0,0)+deriving instance FromJSONKey UserId+deriving instance ToJSONKey UserId+#endif++------------------------------------------------------------------------------+-- | This will be replaced by a role-based permission system.+data Role = Role ByteString+  deriving (Read, Show, Ord, Eq)+++------------------------------------------------------------------------------+-- | Type representing the concept of a User in your application.+data AuthUser = AuthUser+    { userId               :: Maybe UserId+    , userLogin            :: Text++    -- We have to have an email field for password reset functionality, but we+    -- don't want to force users to log in with their email address.+    , userEmail            :: Maybe Text+    , userPassword         :: Maybe Password+    , userActivatedAt      :: Maybe UTCTime+    , userSuspendedAt      :: Maybe UTCTime+    , userRememberToken    :: Maybe Text+    , userLoginCount       :: Int+    , userFailedLoginCount :: Int+    , userLockedOutUntil   :: Maybe UTCTime+    , userCurrentLoginAt   :: Maybe UTCTime+    , userLastLoginAt      :: Maybe UTCTime+    , userCurrentLoginIp   :: Maybe ByteString+    , userLastLoginIp      :: Maybe ByteString+    , userCreatedAt        :: Maybe UTCTime+    , userUpdatedAt        :: Maybe UTCTime+    , userResetToken       :: Maybe Text+    , userResetRequestedAt :: Maybe UTCTime+    , userRoles            :: [Role]+    , userMeta             :: HashMap Text Value+    }+  deriving (Show,Eq)+++------------------------------------------------------------------------------+-- | Default AuthUser that has all empty values.+defAuthUser :: AuthUser+defAuthUser = AuthUser+    { userId               = Nothing+    , userLogin            = ""+    , userEmail            = Nothing+    , userPassword         = Nothing+    , userActivatedAt      = Nothing+    , userSuspendedAt      = Nothing+    , userRememberToken    = Nothing+    , userLoginCount       = 0+    , userFailedLoginCount = 0+    , userLockedOutUntil   = Nothing+    , userCurrentLoginAt   = Nothing+    , userLastLoginAt      = Nothing+    , userCurrentLoginIp   = Nothing+    , userLastLoginIp      = Nothing+    , userCreatedAt        = Nothing+    , userUpdatedAt        = Nothing+    , userResetToken       = Nothing+    , userResetRequestedAt = Nothing+    , userRoles            = []+    , userMeta             = HM.empty+    }+++------------------------------------------------------------------------------+-- | Set a new password for the given user. Given password should be+-- clear-text; it will be encrypted into a 'Encrypted'.+setPassword :: AuthUser -> ByteString -> IO AuthUser+setPassword au pass = do+    pw <- Encrypted <$> makePassword pass defaultStrength+    return $! au { userPassword = Just pw }+++------------------------------------------------------------------------------+-- | Authentication settings defined at initialization time+data AuthSettings = AuthSettings {+    asMinPasswdLen       :: Int+      -- ^ Currently not used/checked++  , asRememberCookieName :: ByteString+      -- ^ Name of the desired remember cookie++  , asRememberPeriod     :: Maybe Int+      -- ^ How long to remember when the option is used in rest of the API.+    -- 'Nothing' means remember until end of session.++  , asLockout            :: Maybe (Int, NominalDiffTime)+      -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration])++  , asSiteKey            :: FilePath+      -- ^ Location of app's encryption key+}+++------------------------------------------------------------------------------+-- | Default settings for Auth.+--+-- > asMinPasswdLen = 8+-- > asRememberCookieName = "_remember"+-- > asRememberPeriod = Just (2*7*24*60*60) = 2 weeks+-- > asLockout = Nothing+-- > asSiteKey = "site_key.txt"+defAuthSettings :: AuthSettings+defAuthSettings = AuthSettings {+    asMinPasswdLen       = 8+  , asRememberCookieName = "_remember"+  , asRememberPeriod     = Just (2*7*24*60*60)+  , asLockout            = Nothing+  , asSiteKey            = "site_key.txt"+}+++------------------------------------------------------------------------------+-- | Function to get auth settings from a config file.  This function can be+-- used by the authors of auth snaplet backends in the initializer to let the+-- user configure the auth snaplet from a config file.  All options are+-- optional and default to what's in defAuthSettings if not supplied.+-- Here's what the default options would look like in the config file:+--+-- > minPasswordLen = 8+-- > rememberCookie = "_remember"+-- > rememberPeriod = 1209600 # 2 weeks+-- > lockout = [5, 86400] # 5 attempts locks you out for 86400 seconds+-- > siteKey = "site_key.txt"+authSettingsFromConfig :: Initializer b v AuthSettings+authSettingsFromConfig = do+    config <- getSnapletUserConfig+    minPasswordLen <- liftIO $ C.lookup config "minPasswordLen"+    let pw = maybe id (\x s -> s { asMinPasswdLen = x }) minPasswordLen+    rememberCookie <- liftIO $ C.lookup config "rememberCookie"+    let rc = maybe id (\x s -> s { asRememberCookieName = x }) rememberCookie+    rememberPeriod <- liftIO $ C.lookup config "rememberPeriod"+    let rp = maybe id (\x s -> s { asRememberPeriod = Just x }) rememberPeriod+    lockout <- liftIO $ C.lookup config "lockout"+    let lo = maybe id (\x s -> s { asLockout = Just (second fromInteger x) })+                   lockout+    siteKey <- liftIO $ C.lookup config "siteKey"+    let sk = maybe id (\x s -> s { asSiteKey = x }) siteKey+    return $ (pw . rc . rp . lo . sk) defAuthSettings+++                             --------------------+                             -- JSON Instances --+                             --------------------++------------------------------------------------------------------------------+instance ToJSON AuthUser where+  toJSON u = object+    [ "uid"                .= userId                u+    , "login"              .= userLogin             u+    , "email"              .= userEmail             u+    , "pw"                 .= userPassword          u+    , "activated_at"       .= userActivatedAt       u+    , "suspended_at"       .= userSuspendedAt       u+    , "remember_token"     .= userRememberToken     u+    , "login_count"        .= userLoginCount        u+    , "failed_login_count" .= userFailedLoginCount  u+    , "locked_until"       .= userLockedOutUntil    u+    , "current_login_at"   .= userCurrentLoginAt    u+    , "last_login_at"      .= userLastLoginAt       u+    , "current_ip"         .= fmap decodeUtf8 (userCurrentLoginIp u)+    , "last_ip"            .= fmap decodeUtf8 (userLastLoginIp u)+    , "created_at"         .= userCreatedAt         u+    , "updated_at"         .= userUpdatedAt         u+    , "reset_token"        .= userResetToken        u+    , "reset_requested_at" .= userResetRequestedAt  u+    , "roles"              .= userRoles             u+    , "meta"               .= userMeta              u+    ]+++------------------------------------------------------------------------------+instance FromJSON AuthUser where+  parseJSON (Object v) = AuthUser+    <$> v .: "uid"+    <*> v .: "login"+    <*> v .: "email"+    <*> v .: "pw"+    <*> v .: "activated_at"+    <*> v .: "suspended_at"+    <*> v .: "remember_token"+    <*> v .: "login_count"+    <*> v .: "failed_login_count"+    <*> v .: "locked_until"+    <*> v .: "current_login_at"+    <*> v .: "last_login_at"+    <*> fmap (fmap encodeUtf8) (v .: "current_ip")+    <*> fmap (fmap encodeUtf8) (v .: "last_ip")+    <*> v .: "created_at"+    <*> v .: "updated_at"+    <*> v .: "reset_token"+    <*> v .: "reset_requested_at"+    <*> v .:? "roles" .!= []+    <*> v .: "meta"+  parseJSON _ = error "Unexpected JSON input"+++------------------------------------------------------------------------------+instance ToJSON Password where+  toJSON (Encrypted x) = toJSON $ decodeUtf8 x+  toJSON (ClearText _) =+      error "ClearText passwords can't be serialized into JSON"+++------------------------------------------------------------------------------+instance FromJSON Password where+  parseJSON = fmap (Encrypted . encodeUtf8) . parseJSON+++------------------------------------------------------------------------------+instance ToJSON Role where+  toJSON (Role x) = toJSON $ decodeUtf8 x+++------------------------------------------------------------------------------+instance FromJSON Role where+  parseJSON = fmap (Role . encodeUtf8) . parseJSON
+ 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
@@ -0,0 +1,349 @@+------------------------------------------------------------------------------+-- | The Heist snaplet makes it easy to add Heist to your application and use+-- it in other snaplets.+--++module Snap.Snaplet.Heist+  (+  -- * Heist and its type class+    Heist+  , HasHeist(..)++  -- * Initializer Functions+  -- $initializerSection+  , heistInit+  , heistInit'+  , Unclassed.heistReloader+  , Unclassed.setInterpreted+  , Unclassed.getCurHeistConfig +  , addTemplates+  , addTemplatesAt+  , Unclassed.addConfig+  , getHeistState+  , modifyHeistState+  , withHeistState++  -- * Handler Functions+  -- $handlerSection+  , gRender+  , gRenderAs+  , gHeistServe+  , gHeistServeSingle+  , chooseMode++  , cRender+  , cRenderAs+  , cHeistServe+  , cHeistServeSingle++  , render+  , renderAs+  , heistServe+  , heistServeSingle+  , heistLocal+  , withSplices+  , renderWithSplices++  -- * Writing Splices+  -- $spliceSection+  , Unclassed.SnapletHeist+  , Unclassed.SnapletCSplice+  , Unclassed.SnapletISplice++  , clearHeistCache+  ) where++------------------------------------------------------------------------------+import           Prelude hiding (id, (.))+import           Control.Monad.State+import           Data.ByteString (ByteString)+import           Heist+------------------------------------------------------------------------------+import           Snap.Snaplet+import           Snap.Snaplet.Heist.Internal+import qualified Snap.Snaplet.HeistNoClass as Unclassed+import           Snap.Snaplet.HeistNoClass ( heistInit+                                           , heistInit'+                                           , clearHeistCache+                                           )+++------------------------------------------------------------------------------+-- | A single snaplet should never need more than one instance of Heist as a+-- subsnaplet.  This type class allows you to make it easy for other snaplets+-- to get the lens that identifies the heist snaplet.  Here's an example of+-- how the heist snaplet might be declared:+--+-- > data App = App { _heist :: Snaplet (Heist App) }+-- > makeLenses ''App+-- >+-- > instance HasHeist App where heistLens = subSnaplet heist+-- >+-- > appInit = makeSnaplet "app" "" Nothing $ do+-- >     h <- nestSnaplet "heist" heist $ heistInit "templates"+-- >     addConfig h heistConfigWithMyAppSplices+-- >     return $ App h+class HasHeist b where+    -- | A lens to the Heist snaplet.  The b parameter to Heist will+    -- typically be the base state of your application.+    heistLens :: SnapletLens (Snaplet b) (Heist b)+++-- $initializerSection+-- This section contains functions for use in setting up your Heist state+-- during initialization.+++------------------------------------------------------------------------------+-- | Adds templates to the Heist HeistState.  Other snaplets should use+-- this function to add their own templates.  The templates are automatically+-- read from the templates directory in the current snaplet's filesystem root.+addTemplates :: HasHeist b+             => Snaplet (Heist b)+             -> ByteString+                 -- ^ The url prefix for the template routes+             -> Initializer b v ()+addTemplates h pfx = withTop' heistLens (Unclassed.addTemplates h pfx)+++------------------------------------------------------------------------------+-- | Adds templates to the Heist HeistState, and lets you specify where+-- they are found in the filesystem.  Note that the path to the template+-- directory is an absolute path.  This allows you more flexibility in where+-- your templates are located, but means that you have to explicitly call+-- getSnapletFilePath if you want your snaplet to use templates within its+-- normal directory structure.+addTemplatesAt :: HasHeist b+               => Snaplet (Heist b)+               -> ByteString+                   -- ^ URL prefix for template routes+               -> FilePath+                   -- ^ Path to templates+               -> Initializer b v ()+addTemplatesAt h pfx p =+    withTop' heistLens (Unclassed.addTemplatesAt h pfx p)+++------------------------------------------------------------------------------+-- | More general function allowing arbitrary HeistState modification.+getHeistState :: (HasHeist b)+              => Handler b v (HeistState (Handler b b))+getHeistState = Unclassed.getHeistState heistLens+++------------------------------------------------------------------------------+-- | More general function allowing arbitrary HeistState modification.+modifyHeistState :: (HasHeist b)+                 => (HeistState (Handler b b) -> HeistState (Handler b b))+                     -- ^ HeistState modifying function+                 -> Initializer b v ()+modifyHeistState = Unclassed.modifyHeistState' heistLens+++------------------------------------------------------------------------------+-- | Runs a function on with the Heist snaplet's 'HeistState'.+withHeistState :: (HasHeist b)+               => (HeistState (Handler b b) -> a)+                   -- ^ HeistState function to run+               -> Handler b v a+withHeistState = Unclassed.withHeistState' heistLens+++-- $handlerSection+-- This section contains functions in the 'Handler' monad that you'll use in+-- processing requests.  Functions beginning with a 'g' prefix use generic+-- rendering that checks the preferred rendering mode and chooses+-- appropriately.  Functions beginning with a 'c' prefix use compiled template+-- rendering.  The other functions use the older interpreted rendering.+-- Interpreted splices added with addConfig will only work if you use+-- interpreted rendering.+--+-- The generic functions are useful if you are writing general snaplets that+-- use heist, but need to work for applications that use either interpreted+-- or compiled mode.+++------------------------------------------------------------------------------+-- | Generic version of 'render'/'cRender'.+gRender :: HasHeist b+        => ByteString+            -- ^ Template name+        -> Handler b v ()+gRender t = withTop' heistLens (Unclassed.gRender t)+++------------------------------------------------------------------------------+-- | Generic version of 'renderAs'/'cRenderAs'.+gRenderAs :: HasHeist b+          => ByteString+              -- ^ Content type to render with+          -> ByteString+              -- ^ Template name+          -> Handler b v ()+gRenderAs ct t = withTop' heistLens (Unclassed.gRenderAs ct t)+++------------------------------------------------------------------------------+-- | Generic version of 'heistServe'/'cHeistServe'.+gHeistServe :: HasHeist b => Handler b v ()+gHeistServe = withTop' heistLens Unclassed.gHeistServe+++------------------------------------------------------------------------------+-- | Generic version of 'heistServeSingle'/'cHeistServeSingle'.+gHeistServeSingle :: HasHeist b+                  => ByteString+                      -- ^ Template name+                  -> Handler b v ()+gHeistServeSingle t = withTop' heistLens (Unclassed.gHeistServeSingle t)+++------------------------------------------------------------------------------+-- | Chooses between a compiled action and an interpreted action based on the+-- configured default.+chooseMode :: HasHeist b+           => Handler b v a+               -- ^ A compiled action+           -> Handler b v a+               -- ^ An interpreted action+           -> Handler b v a+chooseMode cAction iAction = do+    mode <- withTop' heistLens $ gets _defMode+    case mode of+      Unclassed.Compiled -> cAction+      Unclassed.Interpreted -> iAction+++------------------------------------------------------------------------------+-- | Renders a compiled template as text\/html. If the given template is not+-- found, this returns 'empty'.+cRender :: HasHeist b+        => ByteString+            -- ^ Template name+        -> Handler b v ()+cRender t = withTop' heistLens (Unclassed.cRender t)+++------------------------------------------------------------------------------+-- | Renders a compiled template as the given content type.  If the given+-- template is not found, this returns 'empty'.+cRenderAs :: HasHeist b+          => ByteString+              -- ^ Content type to render with+          -> ByteString+              -- ^ Template name+          -> Handler b v ()+cRenderAs ct t = withTop' heistLens (Unclassed.cRenderAs ct t)+++------------------------------------------------------------------------------+-- | A compiled version of 'heistServe'.+cHeistServe :: HasHeist b => Handler b v ()+cHeistServe = withTop' heistLens Unclassed.cHeistServe+++------------------------------------------------------------------------------+-- | Analogous to 'fileServeSingle'. If the given template is not found,+-- this throws an error.+cHeistServeSingle :: HasHeist b+                 => ByteString+                     -- ^ Template name+                 -> Handler b v ()+cHeistServeSingle t = withTop' heistLens (Unclassed.cHeistServeSingle t)+++------------------------------------------------------------------------------+-- | Renders a template as text\/html. If the given template is not found,+-- this returns 'empty'.+render :: HasHeist b+       => ByteString+           -- ^ Template name+       -> Handler b v ()+render t = withTop' heistLens (Unclassed.render t)+++------------------------------------------------------------------------------+-- | Renders a template as the given content type.  If the given template+-- is not found, this returns 'empty'.+renderAs :: HasHeist b+         => ByteString+             -- ^ Content type to render with+         -> ByteString+             -- ^ Template name+         -> Handler b v ()+renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t)+++------------------------------------------------------------------------------+-- | A handler that serves all the templates (similar to 'serveDirectory').+-- If the template specified in the request path is not found, it returns+-- 'empty'.  Also, this function does not serve any templates beginning with+-- an underscore.  This gives you a way to prevent some templates from being+-- served.  For example, you might have a template that contains only the+-- navbar of your pages, and you probably wouldn't want that template to be+-- visible to the user as a standalone template.  So if you put it in a file+-- called \"_nav.tpl\", this function won't serve it.+heistServe :: HasHeist b => Handler b v ()+heistServe = withTop' heistLens Unclassed.heistServe+++------------------------------------------------------------------------------+-- | Handler for serving a single template (similar to 'fileServeSingle'). If+-- the given template is not found, this throws an error.+heistServeSingle :: HasHeist b+                 => ByteString+                     -- ^ Template name+                 -> Handler b v ()+heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t)+++------------------------------------------------------------------------------+-- | Renders a template with a given set of splices.  This is syntax sugar for+-- a common combination of heistLocal, bindSplices, and render.+renderWithSplices :: HasHeist b+                  => ByteString+                      -- ^ Template name+                  -> Splices (Unclassed.SnapletISplice b)+                      -- ^ Splices to bind+                  -> Handler b v ()+renderWithSplices = Unclassed.renderWithSplices' heistLens+++------------------------------------------------------------------------------+-- | Runs an action with additional splices bound into the Heist+-- 'HeistState'.+withSplices :: HasHeist b+            => Splices (Unclassed.SnapletISplice b)+                -- ^ Splices to bind+            -> Handler b v a+                -- ^ Handler to run+            -> Handler b v a+withSplices = Unclassed.withSplices' heistLens+++------------------------------------------------------------------------------+-- | Runs a handler with a modified 'HeistState'.  You might want to use+-- this if you had a set of splices which were customised for a specific+-- action.  To do that you would do:+--+-- > heistLocal (bindSplices mySplices) handlerThatNeedsSplices+heistLocal :: HasHeist b+           => (HeistState (Handler b b) -> HeistState (Handler b b))+               -- ^ HeistState modifying function+           -> Handler b v a+               -- ^ Handler to run+           -> Handler b v a+heistLocal = Unclassed.heistLocal' heistLens+++-- $spliceSection+-- The type signature for SnapletHeist uses @(Handler b b)@ as the Heist+-- snaplet's runtime monad.  This means that your splices must use the+-- top-level snaplet's @Handler b b@ monad.  The reasons for this are beyond+-- the scope of this discussion, but the result is that 'lift' inside a splice+-- only works with @Handler b b@ actions.  When you're writing your own+-- snaplets using some snaplet-specific monad @Handler b v@ you still have to+-- use @Handler b b@ for your splices.  If the splices need any of the context+-- provided by the @v@, you must pass it in as a parameter to the splice+-- function.+
+ 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
@@ -0,0 +1,482 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE TypeSynonymInstances       #-}++{-|++This module implements the Heist snaplet without using type classes.  It is+provided mainly as an example of how snaplets can be written with and without+a type class for convenience.++-}+module Snap.Snaplet.HeistNoClass+  ( Heist+  , DefaultMode(..)+  , heistInit+  , heistInit'+  , heistReloader+  , setInterpreted+  , getCurHeistConfig+  , clearHeistCache++  , addTemplates+  , addTemplatesAt+  , getHeistState+  , modifyHeistState+  , modifyHeistState'+  , withHeistState+  , withHeistState'++  , gRender+  , gRenderAs+  , gHeistServe+  , gHeistServeSingle+  , chooseMode++  , addConfig+  , cRender+  , cRenderAs+  , cHeistServe+  , cHeistServeSingle++  , render+  , renderAs+  , heistServe+  , heistServeSingle+  , heistLocal+  , withSplices+  , renderWithSplices+  , heistLocal'+  , withSplices'+  , renderWithSplices'++  , SnapletHeist+  , SnapletISplice+  , SnapletCSplice+  ) where++import           Prelude hiding ((.), id)+import           Control.Applicative+import           Control.Category+import           Control.Lens+import           Control.Monad.Reader+import           Control.Monad.State+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import           Data.DList (DList)+import qualified Data.HashMap.Strict as Map+import           Data.IORef+import           Data.Maybe+import qualified Data.Text as T+import           Data.Text.Encoding+import           System.FilePath.Posix+import           Heist+import qualified Heist.Compiled as C+import qualified Heist.Interpreted as I+import           Heist.Splices.Cache++#if !MIN_VERSION_base(4,8,0)+import           Data.Monoid+#endif++import           Snap.Snaplet+import           Snap.Snaplet.Heist.Internal+import           Snap.Core+import           Snap.Util.FileServe+++------------------------------------------------------------------------------+changeState :: (HeistState (Handler a a) -> HeistState (Handler a a))+            -> Heist a+            -> Heist a+changeState _ (Configuring _)  =+    error "changeState: HeistState has not been initialized"+changeState f (Running hc hs cts dm) = Running hc (f hs) cts dm+++------------------------------------------------------------------------------+-- | Clears data stored by the cache tag.  The cache tag automatically reloads+-- its data when the specified TTL expires, but sometimes you may want to+-- trigger a manual reload.  This function lets you do that.+clearHeistCache :: Heist b -> IO ()+clearHeistCache = clearCacheTagState . _heistCTS+++                         -----------------------------+                         -- SnapletSplice functions --+                         -----------------------------++------------------------------------------------------------------------------+-- | This instance is here because we don't want the heist package to depend+-- on anything from snap packages.+instance MonadSnap m => MonadSnap (HeistT n m) where+    liftSnap = lift . liftSnap+++type SnapletHeist b m a = HeistT (Handler b b) m a+type SnapletCSplice b = SnapletHeist b IO (DList (Chunk (Handler b b)))+type SnapletISplice b = SnapletHeist b (Handler b b) Template+++                          ---------------------------+                          -- Initializer functions --+                          ---------------------------+++------------------------------------------------------------------------------+-- | The 'Initializer' for 'Heist'. This function is a convenience wrapper+-- around `heistInit'` that uses defaultHeistState and sets up routes for all+-- the templates.  It sets up a \"heistReload\" route that reloads the heist+-- templates when you request it from localhost.+heistInit :: FilePath+              -- ^ Path to templates+          -> SnapletInit b (Heist b)+heistInit = gHeistInit heistServe+++------------------------------------------------------------------------------+-- | A lower level 'Initializer' for 'Heist'.  This initializer requires you+-- to specify the initial HeistConfig.  It also does not add any routes for+-- templates, allowing you complete control over which templates get routed.+heistInit' :: FilePath+               -- ^ Path to templates+           -> HeistConfig (Handler b b)+               -- ^ Initial HeistConfig+           -> SnapletInit b (Heist b)+heistInit' templateDir initialConfig =+    makeSnaplet "heist" "" Nothing $ heistInitWorker templateDir initialConfig+++------------------------------------------------------------------------------+-- | Sets the snaplet to default to interpreted mode.  Initially, the+-- initializer sets the value to compiled mode.  This function allows you to+-- override that setting.  Note that this is just a default.  It only has an+-- effect if you use one of the generic functions: 'gRender', 'gRenderAs',+-- 'gHeistServe', or 'gHeistServeSingle'.  If you call the non-generic+-- versions directly, then this value will not be checked and you will get the+-- mode implemented by the function you called.+setInterpreted :: Snaplet (Heist b) -> Initializer b v ()+setInterpreted h =+    liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h)+        (\(hc,_) -> ((hc,Interpreted),()))+++------------------------------------------------------------------------------+-- | Adds templates to the Heist HeistConfig.  Other snaplets should use+-- this function to add their own templates.  The templates are automatically+-- read from the templates directory in the current snaplet's filesystem root.+addTemplates :: Snaplet (Heist b)+             -> ByteString+                 -- ^ The url prefix for the template routes+             -> Initializer b (Heist b) ()+addTemplates h urlPrefix = do+    snapletPath <- getSnapletFilePath+    addTemplatesAt h urlPrefix (snapletPath </> "templates")+++------------------------------------------------------------------------------+-- | Adds templates to the Heist HeistConfig, and lets you specify where+-- they are found in the filesystem.  Note that the path to the template+-- directory is an absolute path.  This allows you more flexibility in where+-- your templates are located, but means that you have to explicitly call+-- getSnapletFilePath if you want your snaplet to use templates within its+-- normal directory structure.+addTemplatesAt :: Snaplet (Heist b)+               -> ByteString+                   -- ^ URL prefix for template routes+               -> FilePath+                   -- ^ Path to templates+               -> Initializer b (Heist b) ()+addTemplatesAt h urlPrefix templateDir = do+    rootUrl <- getSnapletRootURL+    let fullPrefix = (T.unpack $ decodeUtf8 rootUrl) </>+                     (T.unpack $ decodeUtf8 urlPrefix)+        addPrefix = addTemplatePathPrefix+                      (encodeUtf8 $ T.pack fullPrefix)+    ts <- liftIO $ (loadTemplates templateDir) >>=+                   either (error . concat) return+    printInfo $ T.pack $ unwords+        [ "...adding"+        , (show $ Map.size ts)+        , "templates from"+        , templateDir+        , "with route prefix"+        , fullPrefix ++ "/"+        ]+    let locations = [fmap addPrefix <$> loadTemplates templateDir]+        add (hc, dm) =+          ((over hcTemplateLocations (mappend locations) hc, dm), ())+    liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) add+++getCurHeistConfig :: Snaplet (Heist b)+                  -> Initializer b v (HeistConfig (Handler b b))+getCurHeistConfig h = case view snapletValue h of+    Configuring ref -> do+        (hc, _) <- liftIO $ readIORef ref+        return hc+    Running _ _ _ _ ->+        error "Can't get HeistConfig after heist is initialized."+++------------------------------------------------------------------------------+getHeistState :: SnapletLens (Snaplet b) (Heist b)+              -> Handler b v (HeistState (Handler b b))+getHeistState heist = withTop' heist $ gets _heistState+++------------------------------------------------------------------------------+modifyHeistState' :: SnapletLens (Snaplet b) (Heist b)+                  -> (HeistState (Handler b b) -> HeistState (Handler b b))+                  -> Initializer b v ()+modifyHeistState' heist f = do+    withTop' heist $ addPostInitHook $ return . Right . changeState f+++------------------------------------------------------------------------------+modifyHeistState :: SnapletLens b (Heist b)+                 -> (HeistState (Handler b b) -> HeistState (Handler b b))+                 -> Initializer b v ()+modifyHeistState heist f = modifyHeistState' (subSnaplet heist) f+++------------------------------------------------------------------------------+withHeistState' :: SnapletLens (Snaplet b) (Heist b)+                -> (HeistState (Handler b b) -> a)+                -> Handler b v a+withHeistState' heist f = do+    hs <- withTop' heist $ gets _heistState+    return $ f hs+++------------------------------------------------------------------------------+withHeistState :: SnapletLens b (Heist b)+               -> (HeistState (Handler b b) -> a)+               -> Handler b v a+withHeistState heist f = withHeistState' (subSnaplet heist) f+++------------------------------------------------------------------------------+-- | Adds more HeistConfig data using mappend with whatever is currently+-- there.  This is the preferred method for adding all four kinds of splices+-- as well as new templates.+addConfig :: Snaplet (Heist b)+          -> SpliceConfig (Handler b b)+          -> Initializer b v ()+addConfig h sc = case view snapletValue h of+    Configuring ref ->+        liftIO $ atomicModifyIORef ref add+    Running _ _ _ _ -> do+        printInfo "finalLoadHook called while running"+        error "this shouldn't happen"+  where+    add (hc, dm) =+      ((over hcSpliceConfig (`mappend` sc) hc, dm), ())+++                            -----------------------+                            -- Handler functions --+                            -----------------------++------------------------------------------------------------------------------+-- | Internal helper function for rendering.+iRenderHelper :: Maybe MIMEType+             -> ByteString+             -> Handler b (Heist b) ()+iRenderHelper c t = do+    (Running _ hs _ _) <- get+    withTop' id $ I.renderTemplate hs t >>= maybe pass serve+  where+    serve (b, mime) = do+        modifyResponse $ setContentType $ fromMaybe mime c+        writeBuilder b+++------------------------------------------------------------------------------+-- | Internal helper function for rendering.+cRenderHelper :: Maybe MIMEType+              -> ByteString+              -> Handler b (Heist b) ()+cRenderHelper c t = do+    (Running _ hs _ _) <- get+    withTop' id $ maybe pass serve $ C.renderTemplate hs t+  where+    serve (b, mime) = do+        modifyResponse $ setContentType $ fromMaybe mime c+        writeBuilder =<< b+++------------------------------------------------------------------------------+serveURI :: Handler b (Heist b) ByteString+serveURI = do+    p <- getSafePath+    -- Allows users to prefix template filenames with an underscore to prevent+    -- the template from being served.+    if take 1 p == "_" then pass else return $ B.pack p+++------------------------------------------------------------------------------+render :: ByteString+           -- ^ Name of the template+       -> Handler b (Heist b) ()+render t = iRenderHelper Nothing t+++------------------------------------------------------------------------------+renderAs :: ByteString+             -- ^ Content type+         -> ByteString+             -- ^ Name of the template+         -> Handler b (Heist b) ()+renderAs ct t = iRenderHelper (Just ct) t+++------------------------------------------------------------------------------+heistServe :: Handler b (Heist b) ()+heistServe =+    ifTop (render "index") <|> (render =<< serveURI)+++------------------------------------------------------------------------------+heistServeSingle :: ByteString -> Handler b (Heist b) ()+heistServeSingle t =+    render t <|> error ("Template " ++ show t ++ " not found.")+++------------------------------------------------------------------------------+cRender :: ByteString+           -- ^ Name of the template+        -> Handler b (Heist b) ()+cRender t = cRenderHelper Nothing t+++------------------------------------------------------------------------------+cRenderAs :: ByteString+             -- ^ Content type+          -> ByteString+             -- ^ Name of the template+          -> Handler b (Heist b) ()+cRenderAs ct t = cRenderHelper (Just ct) t+++------------------------------------------------------------------------------+cHeistServe :: Handler b (Heist b) ()+cHeistServe =+    ifTop (cRender "index") <|> (cRender =<< serveURI)+++------------------------------------------------------------------------------+cHeistServeSingle :: ByteString -> Handler b (Heist b) ()+cHeistServeSingle t =+    cRender t <|> error ("Template " ++ show t ++ " not found.")+++------------------------------------------------------------------------------+-- | Chooses between a compiled action and an interpreted action based on the+-- configured default.+chooseMode :: MonadState (Heist b1) m+           => m b+               -- ^ A compiled action+           -> m b+               -- ^ An interpreted action+           -> m b+chooseMode cAction iAction = do+    mode <- gets _defMode+    case mode of+      Compiled -> cAction+      Interpreted -> iAction+++------------------------------------------------------------------------------+-- | Like render/cRender, but chooses between the two appropriately based on+-- the default mode.+gRender :: ByteString+           -- ^ Name of the template+        -> Handler b (Heist b) ()+gRender t = chooseMode (cRender t) (render t)+++------------------------------------------------------------------------------+-- | Like renderAs/cRenderAs, but chooses between the two appropriately based+-- on the default mode.+gRenderAs :: ByteString+             -- ^ Content type+          -> ByteString+             -- ^ Name of the template+          -> Handler b (Heist b) ()+gRenderAs ct t = chooseMode (cRenderAs ct t) (renderAs ct t)+++------------------------------------------------------------------------------+-- | Like heistServe/cHeistServe, but chooses between the two appropriately+-- based on the default mode.+gHeistServe :: Handler b (Heist b) ()+gHeistServe = chooseMode cHeistServe heistServe+++------------------------------------------------------------------------------+-- | Like heistServeSingle/cHeistServeSingle, but chooses between the two+-- appropriately based on the default mode.+gHeistServeSingle :: ByteString -> Handler b (Heist b) ()+gHeistServeSingle t = chooseMode (cHeistServeSingle t) (heistServeSingle t)+++------------------------------------------------------------------------------+heistLocal' :: SnapletLens (Snaplet b) (Heist b)+            -> (HeistState (Handler b b) -> HeistState (Handler b b))+            -> Handler b v a+            -> Handler b v a+heistLocal' heist f m = do+    hs  <- withTop' heist get+    withTop' heist $ modify $ changeState f+    res <- m+    withTop' heist $ put hs+    return res+++------------------------------------------------------------------------------+heistLocal :: SnapletLens b (Heist b)+           -> (HeistState (Handler b b) -> HeistState (Handler b b))+           -> Handler b v a+           -> Handler b v a+heistLocal heist f m = heistLocal' (subSnaplet heist) f m+++------------------------------------------------------------------------------+withSplices' :: SnapletLens (Snaplet b) (Heist b)+             -> Splices (SnapletISplice b)+             -> Handler b v a+             -> Handler b v a+withSplices' heist splices m = do+    heistLocal' heist (I.bindSplices splices) m+++------------------------------------------------------------------------------+withSplices :: SnapletLens b (Heist b)+            -> Splices (SnapletISplice b)+            -> Handler b v a+            -> Handler b v a+withSplices heist splices m = withSplices' (subSnaplet heist) splices m+++------------------------------------------------------------------------------+renderWithSplices' :: SnapletLens (Snaplet b) (Heist b)+                   -> ByteString+                   -> Splices (SnapletISplice b)+                   -> Handler b v ()+renderWithSplices' heist t splices =+    withSplices' heist splices $ withTop' heist $ render t+++------------------------------------------------------------------------------+renderWithSplices :: SnapletLens b (Heist b)+                  -> ByteString+                  -> Splices (SnapletISplice b)+                  -> Handler b v ()+renderWithSplices heist t splices =+    renderWithSplices' (subSnaplet heist) t splices
+ src/Snap/Snaplet/Internal/Initializer.hs view
@@ -0,0 +1,705 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++module Snap.Snaplet.Internal.Initializer+  ( addPostInitHook+  , addPostInitHookBase+  , toSnapletHook+  , bracketInit+  , modifyCfg+  , nestSnaplet+  , embedSnaplet+  , makeSnaplet+  , nameSnaplet+  , onUnload+  , addRoutes+  , wrapSite+  , runInitializer+  , runSnaplet+  , combineConfig+  , serveSnaplet+  , serveSnapletNoArgParsing+  , loadAppConfig+  , printInfo+  , getRoutes+  , getEnvironment+  , modifyMaster+  ) where++------------------------------------------------------------------------------+import           Control.Applicative          ((<$>))+import           Control.Concurrent.MVar      (MVar, modifyMVar_, newEmptyMVar,+                                               putMVar, readMVar)+import           Control.Exception.Lifted     (SomeException, catch, try)+import           Control.Lens                 (ALens', cloneLens, over, set,+                                               storing, (^#))+import           Control.Monad                (Monad (..), join, liftM, unless,+                                               when, (=<<))+import           Control.Monad.Reader         (ask)+import           Control.Monad.State          (get, modify)+import           Control.Monad.Trans          (lift, liftIO)+import           Control.Monad.Trans.Writer   hiding (pass)+import           Data.ByteString.Char8        (ByteString)+import qualified Data.ByteString.Char8        as B+import           Data.Configurator            (Worth (..), addToConfig, empty,+                                               loadGroups, subconfig)+import qualified Data.Configurator.Types      as C+import           Data.IORef                   (IORef, atomicModifyIORef,+                                               newIORef, readIORef)+import           Data.Maybe                   (Maybe (..), fromJust, fromMaybe,+                                               isNothing)+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Prelude                      (Bool (..), Either (..), Eq (..),+                                               String, concat, concatMap,+                                               const, either,+                                               error, filter, flip, fst, id,+                                               map, not, show, ($), ($!), (++),+                                               (.))+import           Snap.Core                    (Snap, liftSnap, route)+import           Snap.Http.Server             (Config, completeConfig,+                                               getCompression, getErrorHandler,+                                               getOther, getVerbose, httpServe)+import           Snap.Util.GZip               (withCompression)+import           System.Directory             (copyFile,+                                               createDirectoryIfMissing,+                                               doesDirectoryExist,+                                               getCurrentDirectory)+import           System.Directory.Tree        (DirTree (..), FileName, buildL,+                                               dirTree, readDirectoryWith)+import           System.FilePath.Posix        (dropFileName, makeRelative,+                                               (</>))+import           System.IO                    (FilePath, IO, hPutStrLn, stderr)+------------------------------------------------------------------------------+import           Snap.Snaplet.Config          (AppConfig, appEnvironment,+                                               commandLineAppConfig)+import qualified Snap.Snaplet.Internal.Lensed as L+import qualified Snap.Snaplet.Internal.LensT  as LT+import           Snap.Snaplet.Internal.Types+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | 'get' for InitializerState.+iGet :: Initializer b v (InitializerState b)+iGet = Initializer $ LT.getBase+++------------------------------------------------------------------------------+-- | 'modify' for InitializerState.+iModify :: (InitializerState b -> InitializerState b) -> Initializer b v ()+iModify f = Initializer $ do+    b <- LT.getBase+    LT.putBase $ f b+++------------------------------------------------------------------------------+-- | 'gets' for InitializerState.+iGets :: (InitializerState b -> a) -> Initializer b v a+iGets f = Initializer $ do+    b <- LT.getBase+    return $ f b+++------------------------------------------------------------------------------+-- | Lets you retrieve the list of routes currently set up by an Initializer.+-- This can be useful in debugging.+getRoutes :: Initializer b v [ByteString]+getRoutes = liftM (map fst) $ iGets _handlers++------------------------------------------------------------------------------+-- | Return the current environment string.  This will be the+-- environment given to 'runSnaplet' or from the command line when+-- using 'serveSnaplet'.  Useful for changing behavior during+-- development and testing.+getEnvironment :: Initializer b v String+getEnvironment = iGets _environment++------------------------------------------------------------------------------+-- | Converts a plain hook into a Snaplet hook.+toSnapletHook :: (v -> IO (Either Text v))+              -> (Snaplet v -> IO (Either Text (Snaplet v)))+toSnapletHook f (Snaplet cfg  reset val) = do+    val' <- f val+    return $! Snaplet cfg reset <$> val'+++------------------------------------------------------------------------------+-- | Adds an IO action that modifies the current snaplet state to be run at+-- the end of initialization on the state that was created.  This makes it+-- easier to allow one snaplet's state to be modified by another snaplet's+-- initializer.  A good example of this is when a snaplet has templates that+-- define its views.  The Heist snaplet provides the 'addTemplates' function+-- which allows other snaplets to set up their own templates.  'addTemplates'+-- is implemented using this function.+addPostInitHook :: (v -> IO (Either Text v))+                -> Initializer b v ()+addPostInitHook = addPostInitHook' . toSnapletHook+++addPostInitHook' :: (Snaplet v -> IO (Either Text (Snaplet v)))+                 -> Initializer b v ()+addPostInitHook' h = do+    h' <- upHook h+    addPostInitHookBase h'+++------------------------------------------------------------------------------+-- | Variant of addPostInitHook for when you have things wrapped in a Snaplet.+addPostInitHookBase :: (Snaplet b -> IO (Either Text (Snaplet b)))+                    -> Initializer b v ()+addPostInitHookBase = Initializer . lift . tell . Hook+++------------------------------------------------------------------------------+-- | Helper function for transforming hooks.+upHook :: (Snaplet v -> IO (Either Text (Snaplet v)))+       -> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))+upHook h = Initializer $ do+    l <- ask+    return $ upHook' l h+++------------------------------------------------------------------------------+-- | Helper function for transforming hooks.+upHook' :: Monad m => ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b)+upHook' l h b = do+    v <- h (b ^# l)+    return $ case v of+               Left e -> Left e+               Right v' -> Right $ storing l v' b+++------------------------------------------------------------------------------+-- | Modifies the Initializer's SnapletConfig.+modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v ()+modifyCfg f = iModify $ over curConfig $ \c -> f c+++------------------------------------------------------------------------------+-- | If a snaplet has a filesystem presence, this function creates and copies+-- the files if they dont' already exist.+setupFilesystem :: Maybe (IO FilePath)+                    -- ^ The directory where the snaplet's reference files are+                    -- stored.  Nothing if the snaplet doesn't come with any+                    -- files that need to be installed.+                -> FilePath+                    -- ^ Directory where the files should be copied.+                -> Initializer b v ()+setupFilesystem Nothing _ = return ()+setupFilesystem (Just getSnapletDataDir) targetDir = do+    exists <- liftIO $ doesDirectoryExist targetDir+    unless exists $ do+        printInfo "...setting up filesystem"+        liftIO $ createDirectoryIfMissing True targetDir+        srcDir <- liftIO getSnapletDataDir+        liftIO $ readDirectoryWith (doCopy srcDir targetDir) srcDir+        return ()+  where+    doCopy srcRoot targetRoot filename = do+        createDirectoryIfMissing True directory+        copyFile filename toDir+      where+        toDir = targetRoot </> makeRelative srcRoot filename+        directory = dropFileName toDir+++------------------------------------------------------------------------------+-- | All snaplet initializers must be wrapped in a call to @makeSnaplet@,+-- which handles standardized housekeeping common to all snaplets.+-- Common usage will look something like+-- this:+--+-- @+-- fooInit :: SnapletInit b Foo+-- fooInit = makeSnaplet \"foo\" \"An example snaplet\" Nothing $ do+--     -- Your initializer code here+--     return $ Foo 42+-- @+--+-- Note that you're writing your initializer code in the Initializer monad,+-- and makeSnaplet converts it into an opaque SnapletInit type.  This allows+-- us to use the type system to ensure that the API is used correctly.+makeSnaplet :: Text+                -- ^ A default id for this snaplet.  This is only used when+                -- the end-user has not already set an id using the+                -- nameSnaplet function.+            -> Text+                -- ^ A human readable description of this snaplet.+            -> Maybe (IO FilePath)+                -- ^ The path to the directory holding the snaplet's reference+                -- filesystem content.  This will almost always be the+                -- directory returned by Cabal's getDataDir command, but it+                -- has to be passed in because it is defined in a+                -- package-specific import.  Setting this value to Nothing+                -- doesn't preclude the snaplet from having files in in the+                -- filesystem, it just means that they won't be copied there+                -- automatically.+            -> Initializer b v v+                -- ^ Snaplet initializer.+            -> SnapletInit b v+makeSnaplet snapletId desc getSnapletDataDir m = SnapletInit $ do+    modifyCfg $ \c -> if isNothing $ _scId c+        then set scId (Just snapletId) c else c+    sid <- iGets (T.unpack . fromJust . _scId . _curConfig)+    topLevel <- iGets _isTopLevel+    unless topLevel $ do+        modifyCfg $ over scUserConfig (subconfig (T.pack sid))+        modifyCfg $ \c -> set scFilePath+          (_scFilePath c </> "snaplets" </> sid) c+    iModify (set isTopLevel False)+    modifyCfg $ set scDescription desc+    cfg <- iGets _curConfig+    printInfo $ T.pack $ concat+      ["Initializing "+      ,sid+      ," @ /"+      ,B.unpack $ buildPath $ _scRouteContext cfg+      ]++    -- This has to happen here because it needs to be after scFilePath is set+    -- up but before the config file is read.+    setupFilesystem getSnapletDataDir (_scFilePath cfg)++    env <- iGets _environment+    let configLocation = _scFilePath cfg </> (env ++ ".cfg")+    liftIO $ addToConfig [Optional configLocation]+                         (_scUserConfig cfg)+    mkSnaplet m+++------------------------------------------------------------------------------+-- | Internal function that gets the SnapletConfig out of the initializer+-- state and uses it to create a (Snaplet a).+mkSnaplet :: Initializer b v v -> Initializer b v (Snaplet v)+mkSnaplet m = do+    res <- m+    cfg <- iGets _curConfig+    setInTop <- iGets masterReloader+    l <- getLens+    let modifier = setInTop  . set (cloneLens l . snapletValue)+    return $ Snaplet cfg modifier res++++------------------------------------------------------------------------------+-- | Brackets an initializer computation, restoring curConfig after the+-- computation returns.+bracketInit :: Initializer b v a -> Initializer b v a+bracketInit m = do+    s <- iGet+    res <- m+    iModify (set curConfig (_curConfig s))+    return res+++------------------------------------------------------------------------------+-- | Handles modifications to InitializerState that need to happen before a+-- snaplet is called with either nestSnaplet or embedSnaplet.+setupSnapletCall :: ByteString -> Initializer b v ()+setupSnapletCall rte = do+    curId <- iGets (fromJust . _scId . _curConfig)+    modifyCfg (over scAncestry (curId:))+    modifyCfg (over scId (const Nothing))+    unless (B.null rte) $ modifyCfg (over scRouteContext (rte:))+++------------------------------------------------------------------------------+-- | Runs another snaplet's initializer and returns the initialized Snaplet+-- value.  Calling an initializer with nestSnaplet gives the nested snaplet+-- access to the same base state that the current snaplet has.  This makes it+-- possible for the child snaplet to make use of functionality provided by+-- sibling snaplets.+nestSnaplet :: ByteString+                -- ^ The root url for all the snaplet's routes.  An empty+                -- string gives the routes the same root as the parent+                -- snaplet's routes.+            -> SnapletLens v v1+                -- ^ Lens identifying the snaplet+            -> SnapletInit b v1+                -- ^ The initializer function for the subsnaplet.+            -> Initializer b v (Snaplet v1)+nestSnaplet rte l (SnapletInit snaplet) =+    with l $ bracketInit $ do+        setupSnapletCall rte+        snaplet+++------------------------------------------------------------------------------+-- | Runs another snaplet's initializer and returns the initialized Snaplet+-- value.  The difference between this and 'nestSnaplet' is the first type+-- parameter in the third argument.  The \"v1 v1\" makes the child snaplet+-- think that it is the top-level state, which means that it will not be able+-- to use functionality provided by snaplets included above it in the snaplet+-- tree. This strongly isolates the child snaplet, and allows you to eliminate+-- the b type variable.  The embedded snaplet can still get functionality+-- from other snaplets, but only if it nests or embeds the snaplet itself.+--+-- Note that this function does not change where this snaplet is located in+-- the filesystem.  The snaplet directory structure convention stays the same.+-- Also, embedSnaplet limits the ways that snaplets can interact, so we+-- usually recommend using nestSnaplet instead.  However, we provide this+-- function because sometimes reduced flexibility is useful.  In short, if+-- you don't understand what this function does for you from looking at its+-- type, you probably don't want to use it.+embedSnaplet :: ByteString+                 -- ^ The root url for all the snaplet's routes.  An empty+                 -- string gives the routes the same root as the parent+                 -- snaplet's routes.+                 --+                 -- NOTE: Because of the stronger isolation provided by+                 -- embedSnaplet, you should be more careful about using an+                 -- empty string here.+             -> SnapletLens v v1+                -- ^ Lens identifying the snaplet+             -> SnapletInit v1 v1+                -- ^ The initializer function for the subsnaplet.+             -> Initializer b v (Snaplet v1)+embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do+    curLens <- getLens+    setupSnapletCall ""+    chroot rte (cloneLens curLens . subSnaplet l) snaplet+++------------------------------------------------------------------------------+-- | Changes the base state of an initializer.+chroot :: ByteString+       -> SnapletLens (Snaplet b) v1+       -> Initializer v1 v1 a+       -> Initializer b v a+chroot rte l (Initializer m) = do+    curState <- iGet+    let newSetter f = masterReloader curState (over (cloneLens l) f)+    ((a,s), (Hook hook)) <- liftIO $ runWriterT $ LT.runLensT m id $+        curState {+          _handlers = [],+          _hFilter = id,+          masterReloader = newSetter+        }+    let handler = chrootHandler l $ _hFilter s $ route $ _handlers s+    iModify $ over handlers (++[(rte,handler)])+            . set cleanup (_cleanup s)+    addPostInitHookBase $ upHook' l hook+    return a+++------------------------------------------------------------------------------+-- | Changes the base state of a handler.+chrootHandler :: SnapletLens (Snaplet v) b'+              -> Handler b' b' a -> Handler b v a+chrootHandler l (Handler h) = Handler $ do+    s <- get+    (a, s') <- liftSnap $ L.runLensed h id (s ^# l)+    modify $ storing l s'+    return a+++------------------------------------------------------------------------------+-- | Sets a snaplet's name.  All snaplets have a default name set by the+-- snaplet author.  This function allows you to override that name.  You will+-- have to do this if you have more than one instance of the same kind of+-- snaplet because snaplet names must be unique.  This function must+-- immediately surround the snaplet's initializer.  For example:+--+-- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@+nameSnaplet :: Text+                -- ^ The snaplet name+            -> SnapletInit b v+                -- ^ The snaplet initializer function+            -> SnapletInit b v+nameSnaplet nm (SnapletInit m) = SnapletInit $+    modifyCfg (set scId (Just nm)) >> m+++------------------------------------------------------------------------------+-- | Adds routing to the current 'Handler'.  The new routes are merged with+-- the main routing section and take precedence over existing routing that was+-- previously defined.+addRoutes :: [(ByteString, Handler b v ())]+           -> Initializer b v ()+addRoutes rs = do+    l <- getLens+    ctx <- iGets (_scRouteContext . _curConfig)+    let modRoute (r,h) = ( buildPath (r:ctx)+                         , setPattern r >> withTop' l h)+    let rs' = map modRoute rs+    iModify (\v -> over handlers (++rs') v)+  where+    setPattern r = do+      p <- getRoutePattern+      when (isNothing p) $ setRoutePattern r+++------------------------------------------------------------------------------+-- | Wraps the /base/ snaplet's routing in another handler, allowing you to run+-- code before and after all routes in an application.+--+-- Here are some examples of things you might do:+--+-- > wrapSite (\site -> logHandlerStart >> site >> logHandlerFinished)+-- > wrapSite (\site -> ensureAdminUser >> site)+--+wrapSite :: (Handler b v () -> Handler b v ())+             -- ^ Handler modifier function+         -> Initializer b v ()+wrapSite f0 = do+    f <- mungeFilter f0+    iModify (\v -> over hFilter (f.) v)+++------------------------------------------------------------------------------+mungeFilter :: (Handler b v () -> Handler b v ())+            -> Initializer b v (Handler b b () -> Handler b b ())+mungeFilter f = do+    myLens <- Initializer ask+    return $ \m -> with' myLens $ f' m+  where+    f' (Handler m)       = f $ Handler $ L.withTop id m+++------------------------------------------------------------------------------+-- | Attaches an unload handler to the snaplet.  The unload handler will be+-- called when the server shuts down, or is reloaded.+onUnload :: IO () -> Initializer b v ()+onUnload m = do+    cleanupRef <- iGets _cleanup+    liftIO $ atomicModifyIORef cleanupRef f+  where+    f curCleanup = (curCleanup >> m, ())+++------------------------------------------------------------------------------+-- |+logInitMsg :: IORef Text -> Text -> IO ()+logInitMsg ref msg = atomicModifyIORef ref (\cur -> (cur `T.append` msg, ()))+++------------------------------------------------------------------------------+-- | Initializers should use this function for all informational or error+-- messages to be displayed to the user.  On application startup they will be+-- sent to the console.  When executed from the reloader, they will be sent+-- back to the user in the HTTP response.+printInfo :: Text -> Initializer b v ()+printInfo msg = do+    logRef <- iGets _initMessages+    liftIO $ logInitMsg logRef (msg `T.append` "\n")+++------------------------------------------------------------------------------+-- | Builds an IO reload action for storage in the SnapletState.+mkReloader :: FilePath+           -> String+           -> ((Snaplet b -> Snaplet b) -> IO ())+           -> IORef (IO ())+           -> Initializer b b (Snaplet b)+           -> IO (Either Text Text)+mkReloader cwd env resetter cleanupRef i = do+    join $ readIORef cleanupRef+    !res <- runInitializer' resetter env i cwd+    either (return . Left) good res+  where+    good (b,is) = do+        _ <- resetter (const b)+        msgs <- readIORef $ _initMessages is+        return $ Right msgs+++------------------------------------------------------------------------------+-- | Runs a top-level snaplet in the Snap monad.+runBase :: Handler b b a+        -> MVar (Snaplet b)+        -> Snap a+runBase (Handler m) mvar = do+    !b <- liftIO (readMVar mvar)+    (!a, _) <- L.runLensed m id b+    return $! a+++------------------------------------------------------------------------------+-- | Lets you change a snaplet's initial state.  It's almost like a reload,+-- except that it doesn't run the initializer.  It just modifies the result of+-- the initializer.  This can be used to let you define actions for reloading+-- individual snaplets.+modifyMaster :: v -> Handler b v ()+modifyMaster v = do+    modifier <- getsSnapletState _snapletModifier+    liftIO $ modifier v+++------------------------------------------------------------------------------+-- | Internal function for running Initializers.  If any exceptions were+-- thrown by the initializer, this function catches them, runs any cleanup+-- actions that had been registered, and returns an expanded error message+-- containing the exception details as well as all messages generated by the+-- initializer before the exception was thrown.+runInitializer :: ((Snaplet b -> Snaplet b) -> IO ())+               -> String+               -> Initializer b b (Snaplet b)+               -> IO (Either Text (Snaplet b, InitializerState b))+runInitializer resetter env b =+    getCurrentDirectory >>= runInitializer' resetter env b+++------------------------------------------------------------------------------+runInitializer' :: ((Snaplet b -> Snaplet b) -> IO ())+                -> String+                -> Initializer b b (Snaplet b)+                -> FilePath+                -> IO (Either Text (Snaplet b, InitializerState b))+runInitializer' resetter env b@(Initializer i) cwd = do+    cleanupRef <- newIORef (return ())+    let reloader_ = mkReloader cwd env resetter cleanupRef b+    let builtinHandlers = [("/admin/reload", reloadSite)]+    let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing reloader_+    logRef <- newIORef ""++    let body = do+            ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $+                InitializerState True cleanupRef builtinHandlers id cfg logRef+                                 env resetter+            res' <- hook res+            return $ (,s) <$> res'++        handler e = do+            join $ readIORef cleanupRef+            logMessages <- readIORef logRef++            return $ Left $ T.unlines+                [ "Initializer threw an exception..."+                , T.pack $ show (e :: SomeException)+                , ""+                , "...but before it died it generated the following output:"+                , logMessages+                ]++    catch body handler+++------------------------------------------------------------------------------+-- | Given an environment and a Snaplet initializer, produce a concatenated log+-- of all messages generated during initialization, a snap handler, and a+-- cleanup action.  The environment is an arbitrary string such as \"devel\" or+-- \"production\".  This string is used to determine the name of the+-- configuration files used by each snaplet.  If an environment of Nothing is+-- used, then runSnaplet defaults to \"devel\".+runSnaplet :: Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())+runSnaplet env (SnapletInit b) = do+    snapletMVar <- newEmptyMVar+    let resetter f = modifyMVar_ snapletMVar (return . f)+    eRes <- runInitializer resetter (fromMaybe "devel" env) b+    let go (siteSnaplet,is) = do+            putMVar snapletMVar siteSnaplet+            msgs <- liftIO $ readIORef $ _initMessages is+            let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar+            cleanupAction <- readIORef $ _cleanup is+            return (msgs, handler, cleanupAction)+    either (error . ('\n':) . T.unpack) go eRes+++------------------------------------------------------------------------------+-- | Given a configuration and a snap handler, complete it and produce the+-- completed configuration as well as a new toplevel handler with things like+-- compression and a 500 handler set up.+combineConfig :: Config Snap a -> Snap () -> IO (Config Snap a, Snap ())+combineConfig config handler = do+    conf <- completeConfig config++    let catch500 = (flip catch $ fromJust $ getErrorHandler conf)+    let compress = if fromJust (getCompression conf)+                     then withCompression else id+    let site     = compress $ catch500 handler++    return (conf, site)+++------------------------------------------------------------------------------+-- | Initialize and run a Snaplet. This function parses command-line arguments,+-- runs the given Snaplet initializer, and starts an HTTP server running the+-- Snaplet's toplevel 'Handler'.+serveSnaplet :: Config Snap AppConfig+                 -- ^ The configuration of the server - you can usually pass a+                 -- default 'Config' via+                 -- 'Snap.Http.Server.Config.defaultConfig'.+             -> SnapletInit b b+                 -- ^ The snaplet initializer function.+             -> IO ()+serveSnaplet startConfig initializer = do+    config <- commandLineAppConfig startConfig+    serveSnapletNoArgParsing config initializer++------------------------------------------------------------------------------+-- | Like 'serveSnaplet', but don't try to parse command-line arguments.+serveSnapletNoArgParsing :: Config Snap AppConfig+                 -- ^ The configuration of the server - you can usually pass a+                 -- default 'Config' via+                 -- 'Snap.Http.Server.Config.defaultConfig'.+             -> SnapletInit b b+                 -- ^ The snaplet initializer function.+             -> IO ()+serveSnapletNoArgParsing config initializer = do+    let env = appEnvironment =<< getOther config+    (msgs, handler, doCleanup) <- runSnaplet env initializer++    (conf, site) <- combineConfig config handler+    createDirectoryIfMissing False "log"+    let serve = httpServe conf++    when (loggingEnabled conf) $ liftIO $ hPutStrLn stderr $ T.unpack msgs+    _ <- try $ serve $ site+         :: IO (Either SomeException ())+    doCleanup+  where+    loggingEnabled = not . (== Just False) . getVerbose+++------------------------------------------------------------------------------+-- | Allows you to get all of your app's config data in the IO monad without+-- the web server infrastructure.+loadAppConfig :: FileName+              -- ^ The name of the config file to look for.  In snap+              -- applications, this is something based on the+              -- environment...i.e. @devel.cfg@.+              -> FilePath+              -- ^ Path to the root directory of your project.+              -> IO C.Config+loadAppConfig cfg root = do+    tree <- buildL root+    let groups = loadAppConfig' cfg "" $ dirTree tree+    loadGroups groups+++------------------------------------------------------------------------------+-- | Recursive worker for loadAppConfig.+loadAppConfig' :: FileName -> Text -> DirTree a -> [(Text, Worth a)]+loadAppConfig' cfg _prefix d@(Dir _ c) =+    (map ((_prefix,) . Required) $ getCfg cfg d) +++    concatMap (\a -> loadAppConfig' cfg (nextPrefix $ name a) a) snaplets+  where+    nextPrefix p = T.concat [_prefix, T.pack p, "."]+    snapletsDirs = filter isSnapletsDir c+    snaplets = concatMap (filter isDir . contents) snapletsDirs+loadAppConfig' _ _ _ = []+++isSnapletsDir :: DirTree t -> Bool+isSnapletsDir (Dir "snaplets" _) = True+isSnapletsDir _ = False+++isDir :: DirTree t -> Bool+isDir (Dir _ _) = True+isDir _ = False+++isCfg :: FileName -> DirTree t -> Bool+isCfg cfg (File n _) = cfg == n+isCfg _ _ = False+++getCfg :: FileName -> DirTree b -> [b]+getCfg cfg (Dir _ c) = map file $ filter (isCfg cfg) c+getCfg _ _ = []+++
+ src/Snap/Snaplet/Internal/LensT.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++module Snap.Snaplet.Internal.LensT where+++------------------------------------------------------------------------------+import           Control.Applicative         (Alternative (..),+                                              Applicative (..))+import           Control.Category            ((.))+import           Control.Lens                (ALens', cloneLens, storing, (^#))+import           Control.Monad               (MonadPlus (..))+import           Control.Monad.Base          (MonadBase (..))+import           Control.Monad.Reader        (MonadReader (..))+import           Control.Monad.State.Class   (MonadState (..))+import           Control.Monad.Trans         (MonadIO (..), MonadTrans (..))+import           Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),+                                              MonadTransControl (..),+                                              defaultLiftBaseWith,+                                              defaultLiftWith, defaultRestoreM,+                                              defaultRestoreT)+import           Prelude                     (Functor (..), Monad (..), const,+                                              ($), ($!))+import           Snap.Core                   (MonadSnap (..))+import           Snap.Snaplet.Internal.RST   (RST (..), runRST, withRST)+------------------------------------------------------------------------------+++newtype LensT b v s m a = LensT (RST (ALens' b v) s m a)+  deriving ( Monad+           , MonadTrans+           , Functor+           , Applicative+           , MonadIO+           , MonadPlus+           , Alternative+           , MonadReader (ALens' b v))+++------------------------------------------------------------------------------+instance Monad m => MonadState v (LensT b v b m) where+    get = lGet+    put = lPut+++instance MonadBase bs m => MonadBase bs (LensT b v s m) where+    liftBase = lift . liftBase+++instance MonadBaseControl bs m => MonadBaseControl bs (LensT b v s m) where+     type StM (LensT b v s m) a = ComposeSt (LensT b v s) m a+     liftBaseWith = defaultLiftBaseWith+     restoreM = defaultRestoreM+     {-# INLINE liftBaseWith #-}+     {-# INLINE restoreM #-}+++instance MonadTransControl (LensT b v s) where+    type StT (LensT b v s) a = StT (RST (ALens' b v) s) a+    liftWith = defaultLiftWith LensT (\(LensT rst) -> rst)+    restoreT = defaultRestoreT LensT+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}+++instance MonadSnap m => MonadSnap (LensT b v s m) where+    liftSnap m = LensT $ liftSnap m+++------------------------------------------------------------------------------+getBase :: Monad m => LensT b v s m s+getBase = LensT get+{-# INLINE getBase #-}+++------------------------------------------------------------------------------+putBase :: Monad m => s -> LensT b v s m ()+putBase = LensT . put+{-# INLINE putBase #-}+++------------------------------------------------------------------------------+lGet :: Monad m => LensT b v b m v+lGet = LensT $ do+           !l <- ask+           !b <- get+           return $! b ^# l+{-# INLINE lGet #-}+++------------------------------------------------------------------------------+lPut :: Monad m => v -> LensT b v b m ()+lPut v = LensT $ do+             !l <- ask+             !b <- get+             put $! storing l v b+{-# INLINE lPut #-}+++------------------------------------------------------------------------------+runLensT :: Monad m => LensT b v s m a -> ALens' b v -> s -> m (a, s)+runLensT (LensT m) l = runRST m l+{-# INLINE runLensT #-}+++------------------------------------------------------------------------------+withLensT :: Monad m+          => (ALens' b' v' -> ALens' b v)+          -> LensT b v s m a+          -> LensT b' v' s m a+withLensT f (LensT m) = LensT $ withRST f m+{-# INLINE withLensT #-}+++------------------------------------------------------------------------------+withTop :: Monad m+        => ALens' b v'+        -> LensT b v' s m a+        -> LensT b v  s m a+withTop subLens = withLensT (const subLens)+{-# INLINE withTop #-}+++------------------------------------------------------------------------------+with :: Monad m => ALens' v v' -> LensT b v' s m a -> LensT b v s m a+with subLens = withLensT (\l -> cloneLens l . subLens)+
+ src/Snap/Snaplet/Internal/Lensed.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++module Snap.Snaplet.Internal.Lensed where+++------------------------------------------------------------------------------+import           Control.Applicative         (Alternative (..),+                                              Applicative (..), (<$>))+import           Control.Category            ((.))+import           Control.Lens                (ALens', cloneLens, storing, (^#))+import           Control.Monad               (MonadPlus (..), liftM)+import           Control.Monad.Base          (MonadBase (..))+import qualified Control.Monad.Fail          as Fail+import           Control.Monad.Reader        (MonadReader (..))+import           Control.Monad.State.Class   (MonadState (..))+import           Control.Monad.Trans         (MonadIO (..), MonadTrans (..))+import           Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),+                                              MonadTransControl (..),+                                              defaultLiftBaseWith,+                                              defaultRestoreM)+import           Control.Monad.Trans.State   (StateT(..))+import           Prelude                     (Functor (..), Monad (..), ($))+import           Snap.Core                   (MonadSnap (..))+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+newtype Lensed b v m a = Lensed+    { unlensed :: ALens' b v -> v -> b -> m (a, v, b) }+++------------------------------------------------------------------------------+instance Functor m => Functor (Lensed b v m) where+    fmap f (Lensed g) = Lensed $ \l v s ->+        (\(a,v',s') -> (f a, v', s')) <$> g l v s+++------------------------------------------------------------------------------+instance (Functor m, Monad m) => Applicative (Lensed b v m) where+    pure a = Lensed $ \_ v s -> return (a, v, s)+    Lensed mf <*> Lensed ma = Lensed $ \l v s -> do+        (f, v', s') <- mf l v s+        (\(a,v'',s'') -> (f a, v'', s'')) <$> ma l v' s'+++------------------------------------------------------------------------------+instance Fail.MonadFail m => Fail.MonadFail (Lensed b v m) where+    fail s = Lensed $ \_ _ _ -> Fail.fail s+++------------------------------------------------------------------------------+instance Monad m => Monad (Lensed b v m) where+    return a = Lensed $ \_ v s -> return (a, v, s)+    Lensed g >>= k = Lensed $ \l v s -> do+        (a, v', s') <- g l v s+        unlensed (k a) l v' s'+++------------------------------------------------------------------------------+instance Monad m => MonadState v (Lensed b v m) where+    get = Lensed $ \_ v s -> return (v, v, s)+    put v' = Lensed $ \_ _ s -> return ((), v', s)+++instance Monad m => MonadReader (ALens' b v) (Lensed b v m) where+  ask = Lensed $ \l v s -> return (l, v, s)+  local = lensedLocal++------------------------------------------------------------------------------+lensedLocal :: Monad m => (ALens' b v -> ALens' b v') -> Lensed b v' m a -> Lensed b v m a+lensedLocal f g = do+    l <- ask+    withTop (f l) g++------------------------------------------------------------------------------+instance MonadTrans (Lensed b v) where+    lift m = Lensed $ \_ v b -> do+      res <- m+      return (res, v, b)++------------------------------------------------------------------------------+instance MonadIO m => MonadIO (Lensed b v m) where+  liftIO = lift . liftIO+++------------------------------------------------------------------------------+instance MonadPlus m => MonadPlus (Lensed b v m) where+    mzero = lift mzero+    m `mplus` n = Lensed $ \l v b ->+                  unlensed m l v b `mplus` unlensed n l v b+++------------------------------------------------------------------------------+instance (Monad m, Alternative m) => Alternative (Lensed b v m) where+    empty = lift empty+    Lensed m <|> Lensed n = Lensed $ \l v b -> m l v b <|> n l v b+++------------------------------------------------------------------------------+instance MonadSnap m => MonadSnap (Lensed b v m) where+    liftSnap = lift . liftSnap+++------------------------------------------------------------------------------+instance MonadBase base m => MonadBase base (Lensed b v m) where+    liftBase = lift . liftBase+++------------------------------------------------------------------------------+instance MonadBaseControl base m => MonadBaseControl base (Lensed b v m) where+     type StM (Lensed b v m) a = ComposeSt (Lensed b v) m a+     liftBaseWith = defaultLiftBaseWith+     restoreM = defaultRestoreM+     {-# INLINE liftBaseWith #-}+     {-# INLINE restoreM #-}+++------------------------------------------------------------------------------+instance MonadTransControl (Lensed b v) where+    type StT (Lensed b v) a = (a, v, b)+    liftWith f = Lensed $ \l v b -> do+        res <- f $ \(Lensed g) -> g l v b+        return (res, v, b)+    restoreT k = Lensed $ \_ _ _ -> k+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}+++------------------------------------------------------------------------------+globally :: Monad m => StateT b m a -> Lensed b v m a+globally (StateT f) = Lensed $ \l v s ->+                      liftM (\(a, s') -> (a, s' ^# l, s')) $ f (storing l v s)+++------------------------------------------------------------------------------+lensedAsState :: Monad m => Lensed b v m a -> ALens' b v -> StateT b m a+lensedAsState (Lensed f) l = StateT $ \s -> do+    (a, v', s') <- f l (s ^# l) s+    return (a, storing l v' s')+++------------------------------------------------------------------------------+getBase :: Monad m => Lensed b v m b+getBase = Lensed $ \_ v b -> return (b, v, b)+++------------------------------------------------------------------------------+withTop :: Monad m => ALens' b v' -> Lensed b v' m a -> Lensed b v m a+withTop l m = globally $ lensedAsState m l+++------------------------------------------------------------------------------+with :: Monad m => ALens' v v' -> Lensed b v' m a -> Lensed b v m a+with l g = do+    l' <- ask+    withTop (cloneLens l' . l) g+++------------------------------------------------------------------------------+embed :: Monad m => ALens' v v' -> Lensed v v' m a -> Lensed b v m a+embed l m = locally $ lensedAsState m l+++------------------------------------------------------------------------------+locally :: Monad m => StateT v m a -> Lensed b v m a+locally (StateT f) = Lensed $ \_ v s ->+                     liftM (\(a, v') -> (a, v', s)) $ f v+++------------------------------------------------------------------------------+runLensed :: Monad m+          => Lensed t1 b m t+          -> ALens' t1 b+          -> t1+          -> m (t, t1)+runLensed (Lensed f) l s = do+    (a, v', s') <- f l (s ^# l) s+    return (a, storing l v' s')
+ src/Snap/Snaplet/Internal/RST.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++module Snap.Snaplet.Internal.RST where++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 (..))+++------------------------------------------------------------------------------+-- like RWST, but no writer to bog things down. Also assured strict, inlined+-- monad bind, etc+newtype RST r s m a = RST { runRST :: r -> s -> m (a, s) }+++evalRST :: Monad m => RST r s m a -> r -> s -> m a+evalRST m r s = do+    (a,_) <- runRST m r s+    return a+{-# INLINE evalRST #-}+++execRST :: Monad m => RST r s m a -> r -> s -> m s+execRST m r s = do+    (_,!s') <- runRST m r s+    return s'+{-# INLINE execRST #-}+++withRST :: Monad m => (r' -> r) -> RST r s m a -> RST r' s m a+withRST f m = RST $ \r' s -> runRST m (f r') s+{-# INLINE withRST #-}+++instance (Monad m) => MonadReader r (RST r s m) where+    ask = RST $ \r s -> return (r,s)+    local f m = RST $ \r s -> runRST m (f r) s+++instance (Functor m) => Functor (RST r s m) where+    fmap f m = RST $ \r s -> fmap (\(a,s') -> (f a, s')) $ runRST m r s+++instance (Functor m, Monad m) => Applicative (RST r s m) where+    pure = return+    (<*>) = ap+++instance (Functor m, MonadPlus m) => Alternative (RST r s m) where+    empty = mzero+    (<|>) = mplus+++instance (Monad m) => MonadState s (RST r s m) where+    get   = RST $ \_ s -> return (s,s)+    put x = RST $ \_ _ -> return ((),x)+++mapRST :: (m (a, s) -> n (b, s)) -> RST r s m a -> RST r s n b+mapRST f m = RST $ \r s -> f (runRST m r s)+++instance (MonadSnap m) => MonadSnap (RST r s m) where+    liftSnap s = lift $ liftSnap s++rwsBind :: Monad m =>+           RST r s m a+        -> (a -> RST r s m b)+        -> RST r s m b+rwsBind m f = RST go+  where+    go r !s = do+        (a, !s')  <- runRST m r s+        runRST (f a) r s'+{-# INLINE rwsBind #-}++instance (Monad m) => Monad (RST r s m) where+    return a = RST $ \_ s -> return (a, s)+    (>>=)    = rwsBind+#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 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
@@ -0,0 +1,520 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImpredicativeTypes         #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}++#ifndef MIN_VERSION_comonad+#define MIN_VERSION_comonad(x,y,z) 1+#endif++module Snap.Snaplet.Internal.Types where++------------------------------------------------------------------------------+import           Control.Applicative          (Alternative)+import           Control.Lens                 (ALens', makeLenses, set)+import           Control.Monad                (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)++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative          (Applicative)+import           Data.Monoid                  (Monoid (mappend, mempty))+#endif++#if !MIN_VERSION_base(4,11,0)+import           Data.Semigroup               (Semigroup(..))+#endif++------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | An opaque data type holding internal snaplet configuration data.  It is+-- exported publicly because the getOpaqueConfig function in MonadSnaplet+-- makes implementing new instances of MonadSnaplet more convenient.+data SnapletConfig = SnapletConfig+    { _scAncestry        :: [Text]+    , _scFilePath        :: FilePath+    , _scId              :: Maybe Text+    , _scDescription     :: Text+    , _scUserConfig      :: Config+    , _scRouteContext    :: [ByteString]+    , _scRoutePattern    :: Maybe ByteString+        -- ^ Holds the actual route pattern passed to addRoutes for the+        -- current handler.  Nothing during initialization and before route+        -- dispatech.+    , _reloader          :: IO (Either Text Text) -- might change+        -- ^ This is the universal reload action for the top-level site.  We+        -- can't update this in place to be a reloader for each individual+        -- snaplet because individual snaplets can't be reloaded in isolation+        -- without losing effects that subsequent hooks may have had.+    }++makeLenses ''SnapletConfig+++------------------------------------------------------------------------------+-- | Joins a reversed list of directories into a path.+buildPath :: [ByteString] -> ByteString+buildPath ps = B.intercalate "/" $ filter (not . B.null) $ reverse ps+++------------------------------------------------------------------------------+-- | Joins a reversed list of directories into a path.+getRootURL :: SnapletConfig -> ByteString+getRootURL sc = buildPath $ _scRouteContext sc+++------------------------------------------------------------------------------+-- | Snaplet's type parameter 's' here is user-defined and can be any Haskell+-- type.  A value of type @Snaplet s@ countains a couple of things:+--+-- * a value of type @s@, called the \"user state\".+--+-- * some bookkeeping data the framework uses to plug things together, like+--   the snaplet's configuration, the snaplet's root directory on the+--   filesystem, the snaplet's root URL, and so on.+data Snaplet s = Snaplet+    { _snapletConfig   :: SnapletConfig+    , _snapletModifier :: s -> IO ()+        -- ^ See the _reloader comment for why we have to use this to reload+        -- single snaplets in isolation.  This action won't actually run the+        -- initializer at all.  It will only modify the existing state.  It is+        -- the responsibility of the snaplet author to avoid using this in+        -- situations where it will destroy data in its state that was created+        -- by subsequent hook actions.+    , _snapletValue    :: s+    }++makeLenses ''Snaplet++--instance Functor Snaplet where+--  fmap f (Snaplet c r a) = Snaplet c r (f a)+--+--instance Foldable Snaplet where+--  foldMap f (Snaplet _ _ a) = f a+--+--instance Traversable Snaplet where+--  traverse f (Snaplet c r a) = Snaplet c r <$> f a+--+--instance Comonad Snaplet where+--  extract (Snaplet _ _ a) = a+--+-- #if !(MIN_VERSION_comonad(3,0,0))+-- instance Extend Snaplet where+-- #endif+--   extend f w@(Snaplet c r _) = Snaplet c r (f w)++{-+------------------------------------------------------------------------------+-- | A lens referencing the opaque SnapletConfig data type held inside+-- Snaplet.+snapletConfig :: SimpleLens (Snaplet a) SnapletConfig+++------------------------------------------------------------------------------+-- | A lens referencing the user-defined state type wrapped by a Snaplet.+snapletValue :: SimpleLens (Snaplet a) a+-}+++-- NOTE: We cannot use one of the smaller lens packages because none of them+-- include ALens'.  We have to use ALens' because we use lenses inside f's...+-- f (Lens a b).  That requires ImpredicativeTypes which doesn't work.  We+-- also can't inline the type aliases because ALens' uses Pretext which is a+-- newtype and can't be supplied outside lens in a compatible way.++------------------------------------------------------------------------------+type SnapletLens s a = ALens' s (Snaplet a)+++------------------------------------------------------------------------------+-- | Transforms a lens of the type you get from makeLenses to an similar lens+-- that is more suitable for internal use.+subSnaplet :: SnapletLens a b+           -> SnapletLens (Snaplet a) b+subSnaplet l = snapletValue . l+++------------------------------------------------------------------------------+-- | The m type parameter used in the MonadSnaplet type signatures will+-- usually be either Initializer or Handler, but other monads may sometimes be+-- useful.+--+-- Minimal complete definition:+--+-- * 'withTop'', 'with'', 'getLens', and 'getOpaqueConfig'.+--+class MonadSnaplet m where+    -- | Runs a child snaplet action in the current snaplet's context.  If you+    -- think about snaplet lenses using a filesystem path metaphor, the lens+    -- supplied to this snaplet must be a relative path.  In other words, the+    -- lens's base state must be the same as the current snaplet.+    with :: SnapletLens v v'+             -- ^ A relative lens identifying a snaplet+         -> m b v' a+             -- ^ Action from the lense's snaplet+         -> m b v a+    with l = with' (subSnaplet l)++    -- | Like 'with' but doesn't impose the requirement that the action+    -- being run be a descendant of the current snaplet.  Using our filesystem+    -- metaphor again, the lens for this function must be an absolute+    -- path--it's base must be the same as the current base.+    withTop :: SnapletLens b v'+                -- ^ An \"absolute\" lens identifying a snaplet+            -> m b v' a+                -- ^ Action from the lense's snaplet+            -> m b v a+    withTop l = withTop' (subSnaplet l)++    -- | A variant of 'with' accepting a lens from snaplet to snaplet.  Unlike+    -- the lens used in the above 'with' function, this lens formulation has+    -- an identity, which makes it useful in certain circumstances.  The+    -- lenses generated by 'makeLenses' will not work with this function,+    -- however the lens returned by 'getLens' will.+    --+    -- @with = with' . subSnaplet@+    with' :: SnapletLens (Snaplet v) v'+          -> m b v' a -> m b v a++    -- Not providing a definition for this function in terms of withTop'+    -- allows us to avoid extra Monad type class constraints, making the type+    -- signature easier to read.+    -- with' l m = flip withTop m . (l .) =<< getLens++    -- | The absolute version of 'with''+    withTop' :: SnapletLens (Snaplet b) v'+             -> m b v' a -> m b v a++    -- | Gets the lens for the current snaplet.+    getLens :: m b v (SnapletLens (Snaplet b) v)++    -- | Gets the current snaplet's opaque config data type.  You'll only use+    -- this function when writing MonadSnaplet instances.+    getOpaqueConfig :: m b v SnapletConfig+    -- NOTE: We can't just use a MonadState (Snaplet v) instance for this+    -- because Initializer has SnapletConfig, but doesn't have a full Snaplet.+++------------------------------------------------------------------------------+-- | Gets a list of the names of snaplets that are direct ancestors of the+-- current snaplet.+getSnapletAncestry :: (Monad (m b v), MonadSnaplet m) => m b v [Text]+getSnapletAncestry = return . _scAncestry =<< getOpaqueConfig+++------------------------------------------------------------------------------+-- | Gets the snaplet's path on the filesystem.+getSnapletFilePath :: (Monad (m b v), MonadSnaplet m) => m b v FilePath+getSnapletFilePath = return . _scFilePath =<< getOpaqueConfig+++------------------------------------------------------------------------------+-- | Gets the current snaple's name.+getSnapletName :: (Monad (m b v), MonadSnaplet m) => m b v (Maybe Text)+getSnapletName = return . _scId =<< getOpaqueConfig+++------------------------------------------------------------------------------+-- | Gets a human readable description of the snaplet.+getSnapletDescription :: (Monad (m b v), MonadSnaplet m) => m b v Text+getSnapletDescription = return . _scDescription =<< getOpaqueConfig+++------------------------------------------------------------------------------+-- | Gets the config data structure for the current snaplet.+getSnapletUserConfig :: (Monad (m b v), MonadSnaplet m) => m b v Config+getSnapletUserConfig = return . _scUserConfig =<< getOpaqueConfig+++------------------------------------------------------------------------------+-- | Gets the base URL for the current snaplet.  Directories get added to+-- the current snaplet path by calls to 'nestSnaplet'.+getSnapletRootURL :: (Monad (m b v), MonadSnaplet m) => m b v ByteString+getSnapletRootURL = liftM getRootURL getOpaqueConfig+++------------------------------------------------------------------------------+-- | Constructs a url relative to the current snaplet.+snapletURL :: (Monad (m b v), MonadSnaplet m)+           => ByteString -> m b v ByteString+snapletURL suffix = do+    cfg <- getOpaqueConfig+    return $ buildPath (cleanSuffix : _scRouteContext cfg)+  where+    dropSlash = B.dropWhile (=='/')+    cleanSuffix = B.reverse $ dropSlash $ B.reverse $ dropSlash suffix+++------------------------------------------------------------------------------+-- | Snaplet infrastructure is available during runtime request processing+-- through the Handler monad.  There aren't very many standalone functions to+-- read about here, but this is deceptive.  The key is in the type class+-- instances.  Handler is an instance of 'MonadSnap', which means it is the+-- monad you will use to write all your application routes.  It also has a+-- 'MonadSnaplet' instance, which gives you all the functionality described+-- above.+newtype Handler b v a =+    Handler { _unHandler :: L.Lensed (Snaplet b) (Snaplet v) Snap a }+  deriving ( Monad+           , Functor+           , Applicative+           , MonadFail+           , MonadIO+           , MonadPlus+           , Alternative+           , MonadSnap)+++------------------------------------------------------------------------------+instance MonadBase IO (Handler b v) where+    liftBase = liftIO+++------------------------------------------------------------------------------+newtype StMHandler b v a = StMHandler {+      unStMHandler :: StM (L.Lensed (Snaplet b) (Snaplet v) Snap) a+    }+++instance MonadBaseControl IO (Handler b v) where+    type StM (Handler b v) a = StMHandler b v a+    liftBaseWith f = Handler+                       $ liftBaseWith+                       $ \g' -> f+                       $ \m -> liftM StMHandler+                       $ g' $ _unHandler m+    restoreM = Handler . restoreM . unStMHandler+++------------------------------------------------------------------------------+-- | Gets the @Snaplet v@ from the current snaplet's state.+getSnapletState :: Handler b v (Snaplet v)+getSnapletState = Handler get+++------------------------------------------------------------------------------+-- | Puts a new @Snaplet v@ in the current snaplet's state.+putSnapletState :: Snaplet v -> Handler b v ()+putSnapletState = Handler . put+++------------------------------------------------------------------------------+-- | Modifies the @Snaplet v@ in the current snaplet's state.+modifySnapletState :: (Snaplet v -> Snaplet v) -> Handler b v ()+modifySnapletState f = do+    s <- getSnapletState+    putSnapletState (f s)+++------------------------------------------------------------------------------+-- | Gets the @Snaplet v@ from the current snaplet's state and applies a+-- function to it.+getsSnapletState :: (Snaplet v -> b) -> Handler b1 v b+getsSnapletState f = do+    s <- getSnapletState+    return (f s)+++------------------------------------------------------------------------------+-- | Lets you access the current snaplet's state through the 'MonadState'+-- interface.+instance MonadState v (Handler b v) where+    get = getsSnapletState _snapletValue+    put v = modifySnapletState (set snapletValue v)+++------------------------------------------------------------------------------+-- | Lets you access the current snaplet's state through the 'MonadReader'+-- interface.+instance MonadReader v (Handler b v) where+    ask = getsSnapletState _snapletValue+    local f m = do+        cur <- ask+        put (f cur)+        res <- m+        put cur+        return res+++------------------------------------------------------------------------------+instance MonadSnaplet Handler where+    getLens = Handler ask+    with' !l (Handler !m) = Handler $ L.with l m+    withTop' !l (Handler m) = Handler $ L.withTop l m+    getOpaqueConfig = Handler $ gets _snapletConfig+++------------------------------------------------------------------------------+-- | Like 'runBase', but it doesn't require an MVar to be executed.+runPureBase :: Handler b b a -> Snaplet b -> Snap a+runPureBase (Handler m) b = do+        (!a, _) <- L.runLensed m id b+        return $! a+++------------------------------------------------------------------------------+-- | Gets the route pattern that matched for the handler.  This lets you find+-- out exactly which of the strings you used in addRoutes matched.+getRoutePattern :: Handler b v (Maybe ByteString)+getRoutePattern =+    withTop' id $ liftM _scRoutePattern getOpaqueConfig+++------------------------------------------------------------------------------+-- | Sets the route pattern that matched for the handler.  Use this when to+-- override the default pattern which is the key to the alist passed to+-- addRoutes.+setRoutePattern :: ByteString -> Handler b v ()+setRoutePattern p = withTop' id $+    modifySnapletState (set (snapletConfig . scRoutePattern) (Just p))+++------------------------------------------------------------------------------+-- | Check whether the request comes from localhost.+isLocalhost :: MonadSnap m => m Bool+isLocalhost = do+    rip <- liftM rqClientAddr getRequest+    return $ elem rip [ "127.0.0.1"+                      , "localhost"+                      , "::1" ]+++------------------------------------------------------------------------------+-- | Pass if the request is not coming from localhost.+failIfNotLocal :: MonadSnap m => m b -> m b+failIfNotLocal m = do+    isLocal <- isLocalhost+    if isLocal then m else pass+++------------------------------------------------------------------------------+-- | Handler that reloads the site.+reloadSite :: Handler b v ()+reloadSite = failIfNotLocal $ do+    cfg <- getOpaqueConfig+    !res <- liftIO $ _reloader cfg+    either bad good res+  where+    bad msg = do+        writeText $ "Error reloading site!\n\n"+        writeText msg+    good msg = do+        writeText msg+        writeText $ "Site successfully reloaded.\n"+++------------------------------------------------------------------------------+-- | This function brackets a Handler action in resource acquisition and+-- release.  Like 'bracketSnap',  this is provided because MonadCatchIO's+-- 'bracket' function doesn't work properly in the case of a short-circuit+-- return from the action being bracketed.+--+-- In order to prevent confusion regarding the effects of the+-- aquisition and release actions on the Handler state, this function+-- doesn't accept Handler actions for the acquire or release actions.+--+-- This function will run the release action in all cases where the+-- acquire action succeeded.  This includes the following behaviors+-- from the bracketed Snap action.+--+-- 1. Normal completion+--+-- 2. Short-circuit completion, either from calling 'fail' or 'finishWith'+--+-- 3. An exception being thrown.+bracketHandler :: IO a -> (a -> IO x) -> (a -> Handler b v c) -> Handler b v c+bracketHandler begin end f = Handler . L.Lensed $ \l v b -> do+    bracketSnap begin end $ \a -> case f a of Handler m -> L.unlensed m l v b+++------------------------------------------------------------------------------+-- | Information about a partially constructed initializer.  Used to+-- automatically aggregate handlers and cleanup actions.+data InitializerState b = InitializerState+    { _isTopLevel      :: Bool+    , _cleanup         :: IORef (IO ())+    , _handlers        :: [(ByteString, Handler b b ())]+        -- ^ Handler routes built up and passed to route.+    , _hFilter         :: Handler b b () -> Handler b b ()+        -- ^ Generic filtering of handlers+    , _curConfig       :: SnapletConfig+        -- ^ This snaplet config is the incrementally built config for+        -- whatever snaplet is currently being constructed.+    , _initMessages    :: IORef Text+    , _environment     :: String+    , masterReloader   :: (Snaplet b -> Snaplet b) -> IO ()+        -- ^ We can't just hae a simple MVar here because MVars can't be+        -- chrooted.+    }+++------------------------------------------------------------------------------+-- | Wrapper around IO actions that modify state elements created during+-- initialization.+newtype Hook a = Hook (Snaplet a -> IO (Either Text (Snaplet a)))++instance Semigroup (Hook a) where+    Hook a <> Hook b = Hook $ \s -> do+      ea <- a s+      case ea of+        Left e -> return $ Left e+        Right ares -> do+          eb <- b ares+          case eb of+            Left e -> return $ Left e+            Right bres -> return $ Right bres+++------------------------------------------------------------------------------+instance Monoid (Hook a) where+    mempty = Hook (return . Right)+#if !MIN_VERSION_base(4,11,0)+    mappend = (<>)+#endif+++------------------------------------------------------------------------------+-- | Monad used for initializing snaplets.+newtype Initializer b v a =+    Initializer (LT.LensT (Snaplet b)+                          (Snaplet v)+                          (InitializerState b)+                          (WriterT (Hook b) IO)+                          a)+  deriving (Applicative, Functor, Monad, MonadIO)++makeLenses ''InitializerState+++------------------------------------------------------------------------------+instance MonadSnaplet Initializer where+    getLens = Initializer ask+    with' !l (Initializer !m) = Initializer $ LT.with l m+    withTop' !l (Initializer m) = Initializer $ LT.withTop l m+    getOpaqueConfig = Initializer $ liftM _curConfig LT.getBase+++------------------------------------------------------------------------------+-- | Opaque newtype which gives us compile-time guarantees that the user is+-- using makeSnaplet and either nestSnaplet or embedSnaplet correctly.+newtype SnapletInit b v = SnapletInit (Initializer b v (Snaplet v))
+ src/Snap/Snaplet/Session.hs view
@@ -0,0 +1,129 @@+module Snap.Snaplet.Session+  ( SessionManager+  , withSession+  , commitSession+  , setInSession+  , getFromSession+  , deleteFromSession+  , csrfToken+  , sessionToList+  , resetSession+  , touchSession++  -- * Utilities Exported For Convenience+  , module Snap.Snaplet.Session.Common+  , module Snap.Snaplet.Session.SecureCookie+  ) where++------------------------------------------------------------------------------+import           Control.Monad.State+import           Data.Text                           (Text)+import           Snap.Core+------------------------------------------------------------------------------+import           Snap.Snaplet+import           Snap.Snaplet.Session.Common+import           Snap.Snaplet.Session.SecureCookie+import           Snap.Snaplet.Session.SessionManager +                   ( ISessionManager(..), SessionManager(..) )+import qualified Snap.Snaplet.Session.SessionManager as SM+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Wrap around a handler, committing any changes in the session at the end+--+withSession :: SnapletLens b SessionManager+            -> Handler b v a+            -> Handler b v a+withSession l h = do+    a <- h+    withTop l commitSession+    return a+++------------------------------------------------------------------------------+-- | Commit changes to session within the current request cycle+--+commitSession :: Handler b SessionManager ()+commitSession = do+    SessionManager b <- loadSession+    liftSnap $ commit b+++------------------------------------------------------------------------------+-- | Set a key-value pair in the current session+--+setInSession :: Text -> Text -> Handler b SessionManager ()+setInSession k v = do+    SessionManager r <- loadSession+    let r' = SM.insert k v r+    put $ SessionManager r'+++------------------------------------------------------------------------------+-- | Get a key from the current session+--+getFromSession :: Text -> Handler b SessionManager (Maybe Text)+getFromSession k = do+    SessionManager r <- loadSession+    return $ SM.lookup k r+++------------------------------------------------------------------------------+-- | Remove a key from the current session+--+deleteFromSession :: Text -> Handler b SessionManager ()+deleteFromSession k = do+    SessionManager r <- loadSession+    let r' = SM.delete k r+    put $ SessionManager r'+++------------------------------------------------------------------------------+-- | Returns a CSRF Token unique to the current session+--+csrfToken :: Handler b SessionManager Text+csrfToken = do+    mgr@(SessionManager r) <- loadSession+    put mgr+    return $ SM.csrf r+++------------------------------------------------------------------------------+-- | Return session contents as an association list+--+sessionToList :: Handler b SessionManager [(Text, Text)]+sessionToList = do+    SessionManager r <- loadSession+    return $ SM.toList r+++------------------------------------------------------------------------------+-- | Deletes the session cookie, effectively resetting the session+--+resetSession :: Handler b SessionManager ()+resetSession = do+    SessionManager r <- loadSession+    r' <- liftSnap $ SM.reset r+    put $ SessionManager r'+++------------------------------------------------------------------------------+-- | Touch the session so the timeout gets refreshed+--+touchSession :: Handler b SessionManager ()+touchSession = do+    SessionManager r <- loadSession+    let r' = SM.touch r+    put $ SessionManager r'+++------------------------------------------------------------------------------+-- | Load the session into the manager+--+loadSession :: Handler b SessionManager SessionManager+loadSession = do+    SessionManager r <- get+    r' <- liftSnap $ load r+    return $ SessionManager r'+
+ src/Snap/Snaplet/Session/Backends/CookieSession.hs view
@@ -0,0 +1,205 @@+------------------------------------------------------------------------------+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++module Snap.Snaplet.Session.Backends.CookieSession+    ( initCookieSessionManager+    ) where++------------------------------------------------------------------------------+import           Control.Monad.Reader+import           Data.ByteString                     (ByteString)+import           Data.Typeable+import           Data.HashMap.Strict                 (HashMap)+import qualified Data.HashMap.Strict                 as HM+import           Data.Serialize                      (Serialize)+import qualified Data.Serialize                      as S+import           Data.Text                           (Text)+import           Data.Text.Encoding+import           Snap.Core                           (Snap)+import           Web.ClientSession++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif+------------------------------------------------------------------------------+import           Snap.Snaplet+import           Snap.Snaplet.Session+import           Snap.Snaplet.Session.SessionManager+-------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Session data are kept in a 'HashMap' for this backend+--+type Session = HashMap Text Text+++------------------------------------------------------------------------------+-- | This is what the 'Payload' will be for the CookieSession backend+--+data CookieSession = CookieSession+    { csCSRFToken :: Text+    , csSession   :: Session+    }+  deriving (Eq, Show)+++------------------------------------------------------------------------------+instance Serialize CookieSession where+    put (CookieSession a b) =+        S.put (encodeUtf8 a, map encodeTuple $ HM.toList b)+    get                     =+        let unpack (a,b) = CookieSession (decodeUtf8 a)+                                         (HM.fromList $ map decodeTuple b)+        in  unpack <$> S.get+++encodeTuple :: (Text, Text) -> (ByteString, ByteString)+encodeTuple (a,b) = (encodeUtf8 a, encodeUtf8 b)+++decodeTuple :: (ByteString, ByteString) -> (Text, Text)+decodeTuple (a,b) = (decodeUtf8 a, decodeUtf8 b)+++------------------------------------------------------------------------------+mkCookieSession :: RNG -> IO CookieSession+mkCookieSession rng = do+    t <- liftIO $ mkCSRFToken rng+    return $ CookieSession t HM.empty+++------------------------------------------------------------------------------+-- | The manager data type to be stuffed into 'SessionManager'+--+data CookieSessionManager = CookieSessionManager {+      session               :: Maybe CookieSession+        -- ^ Per request cache for 'CookieSession'+    , siteKey               :: Key+        -- ^ A long encryption key used for secure cookie transport+    , cookieName            :: ByteString+        -- ^ Cookie name for the session system+    , cookieDomain          :: Maybe ByteString+        -- ^ Cookie domain for session system. You may want to set it to+        -- dot prefixed domain name like ".example.com", so the cookie is+        -- available to sub domains.+    , timeOut               :: Maybe Int+        -- ^ Session cookies will be considered "stale" after this many+        -- seconds.+    , randomNumberGenerator :: RNG+        -- ^ handle to a random number generator+} deriving (Typeable)+++------------------------------------------------------------------------------+loadDefSession :: CookieSessionManager -> IO CookieSessionManager+loadDefSession mgr@(CookieSessionManager ses _ _ _ _ rng) =+    case ses of+      Nothing -> do ses' <- mkCookieSession rng+                    return $! mgr { session = Just ses' }+      Just _  -> return mgr+++------------------------------------------------------------------------------+modSession :: (Session -> Session) -> CookieSession -> CookieSession+modSession f (CookieSession t ses) = CookieSession t (f ses)+++------------------------------------------------------------------------------+-- | Initialize a cookie-backed session, returning a 'SessionManager' to be+-- stuffed inside your application's state. This 'SessionManager' will enable+-- the use of all session storage functionality defined in+-- 'Snap.Snaplet.Session'+--+initCookieSessionManager+    :: FilePath             -- ^ Path to site-wide encryption key+    -> ByteString           -- ^ Session cookie name+    -> Maybe ByteString     -- ^ Session cookie domain+    -> Maybe Int            -- ^ Session time-out (replay attack protection)+    -> SnapletInit b SessionManager+initCookieSessionManager fp cn dom to =+    makeSnaplet "CookieSession"+                "A snaplet providing sessions via HTTP cookies."+                Nothing $ liftIO $ do+        key <- getKey fp+        rng <- liftIO mkRNG+        return $! SessionManager $ CookieSessionManager Nothing key cn dom to rng+++------------------------------------------------------------------------------+instance ISessionManager CookieSessionManager where++    --------------------------------------------------------------------------+    load mgr@(CookieSessionManager r _ _ _ _ _) =+        case r of+          Just _ -> return mgr+          Nothing -> do+            pl <- getPayload mgr+            case pl of+              Nothing -> liftIO $ loadDefSession mgr+              Just (Payload x) -> do+                let c = S.decode x+                case c of+                  Left _ -> liftIO $ loadDefSession mgr+                  Right cs -> return $ mgr { session = Just cs }++    --------------------------------------------------------------------------+    commit mgr@(CookieSessionManager r _ _ _ _ rng) = do+        pl <- case r of+                Just r' -> return . Payload $ S.encode r'+                Nothing -> liftIO (mkCookieSession rng) >>=+                           return . Payload . S.encode+        setPayload mgr pl++    --------------------------------------------------------------------------+    reset mgr = do+        cs <- liftIO $ mkCookieSession (randomNumberGenerator mgr)+        return $ mgr { session = Just cs }++    --------------------------------------------------------------------------+    touch = id++    --------------------------------------------------------------------------+    insert k v mgr@(CookieSessionManager r _ _ _ _ _) = case r of+        Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }+        Nothing -> mgr++    --------------------------------------------------------------------------+    lookup k (CookieSessionManager r _ _ _ _ _) = r >>= HM.lookup k . csSession++    --------------------------------------------------------------------------+    delete k mgr@(CookieSessionManager r _ _ _ _ _) = case r of+        Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }+        Nothing -> mgr++    --------------------------------------------------------------------------+    csrf (CookieSessionManager r _ _ _ _ _) = case r of+        Just r' -> csCSRFToken r'+        Nothing -> ""++    --------------------------------------------------------------------------+    toList (CookieSessionManager r _ _ _ _ _) = case r of+        Just r' -> HM.toList . csSession $ r'+        Nothing -> []+++------------------------------------------------------------------------------+-- | A session payload to be stored in a SecureCookie.+newtype Payload = Payload ByteString+  deriving (Eq, Show, Ord, Serialize)+++------------------------------------------------------------------------------+-- | Get the current client-side value+getPayload :: CookieSessionManager -> Snap (Maybe Payload)+getPayload mgr = getSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr)+++------------------------------------------------------------------------------+-- | Set the client-side value+setPayload :: CookieSessionManager -> Payload -> Snap ()+setPayload mgr x = setSecureCookie (cookieName mgr) (cookieDomain mgr)+                                   (siteKey mgr) (timeOut mgr) x
+ src/Snap/Snaplet/Session/Common.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE CPP               #-}+------------------------------------------------------------------------------+-- | This module contains functionality common among multiple back-ends.+--++module Snap.Snaplet.Session.Common+  ( RNG+  , mkRNG+  , withRNG+  , randomToken+  , mkCSRFToken+  ) where++------------------------------------------------------------------------------+import           Control.Concurrent+import           Control.Monad+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import qualified Data.Text.Encoding as T+import           Data.Text (Text)+import           Numeric+import           System.Random.MWC++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif+++------------------------------------------------------------------------------+-- | High speed, mutable random number generator state+newtype RNG = RNG (MVar GenIO)++------------------------------------------------------------------------------+-- | Perform given action, mutating the RNG state+withRNG :: RNG+        -> (GenIO -> IO a)+        -> IO a+withRNG (RNG rng) m = withMVar rng m+++------------------------------------------------------------------------------+-- | Create a new RNG+mkRNG :: IO RNG+mkRNG = withSystemRandom (newMVar >=> return . RNG)+++------------------------------------------------------------------------------+-- | Generates a random salt of given length+randomToken :: Int -> RNG -> IO ByteString+randomToken n rng = do+    is <- withRNG rng $ \gen -> sequence . take n . repeat $ mk gen+    return . B.pack . concat . map (flip showHex "") $ is+  where+    mk :: GenIO -> IO Int+    mk = uniformR (0,15)+++------------------------------------------------------------------------------+-- | Generate a randomized CSRF token+mkCSRFToken :: RNG -> IO Text+mkCSRFToken rng = T.decodeUtf8 <$> randomToken 40 rng
+ src/Snap/Snaplet/Session/SecureCookie.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------------------------+-- | This is a support module meant to back all session back-end+-- implementations.+--+-- It gives us an encrypted and timestamped cookie that can store an arbitrary+-- serializable payload. For security, it will:+--+--   * Encrypt its payload together with a timestamp.+--+--   * Check the timestamp for session expiration everytime you read from the+--     cookie. This will limit intercept-and-replay attacks by disallowing+--     cookies older than the timeout threshold.++module Snap.Snaplet.Session.SecureCookie+       ( SecureCookie+       , getSecureCookie+       , setSecureCookie+       , expireSecureCookie+       -- ** Helper functions+       , encodeSecureCookie+       , decodeSecureCookie+       , checkTimeout+       ) where++------------------------------------------------------------------------------+import           Control.Monad+import           Control.Monad.Trans+import           Data.ByteString       (ByteString)+import           Data.Serialize+import           Data.Time+import           Data.Time.Clock.POSIX+import           Snap.Core+import           Web.ClientSession++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif++------------------------------------------------------------------------------+-- | Arbitrary payload with timestamp.+type SecureCookie t = (UTCTime, t)+++------------------------------------------------------------------------------+-- | Get the cookie payload.+getSecureCookie :: (MonadSnap m, Serialize t)+                => ByteString       -- ^ Cookie name+                -> Key              -- ^ Encryption key+                -> Maybe Int        -- ^ Timeout in seconds+                -> m (Maybe t)+getSecureCookie name key timeout = do+    rqCookie <- getCookie name+    rspCookie <- getResponseCookie name <$> getResponse+    let ck = rspCookie `mplus` rqCookie+    let val = fmap cookieValue ck >>= decodeSecureCookie key+    case val of+      Nothing -> return Nothing+      Just (ts, t) -> do+          to <- checkTimeout timeout ts+          return $ case to of+            True -> Nothing+            False -> Just t+++------------------------------------------------------------------------------+-- | Decode secure cookie payload wih key.+decodeSecureCookie  :: Serialize a+                     => Key                     -- ^ Encryption key+                     -> ByteString              -- ^ Encrypted payload+                     -> Maybe (SecureCookie a)+decodeSecureCookie key value = do+    cv <- decrypt key value+    (i, val) <- either (const Nothing) Just $ decode cv+    return $ (posixSecondsToUTCTime (fromInteger i), val)+++------------------------------------------------------------------------------+-- | Inject the payload.+setSecureCookie :: (MonadSnap m, Serialize t)+                => ByteString       -- ^ Cookie name+                -> Maybe ByteString -- ^ Cookie domain+                -> Key              -- ^ Encryption key+                -> Maybe Int        -- ^ Max age in seconds+                -> t                -- ^ Serializable payload+                -> m ()+setSecureCookie name domain key to val = do+    t <- liftIO getCurrentTime+    val' <- encodeSecureCookie key (t, val)+    let expire = to >>= Just . flip addUTCTime t . fromIntegral+    let nc = Cookie name val' expire domain (Just "/") False True+    modifyResponse $ addResponseCookie nc+++------------------------------------------------------------------------------+-- | Encode SecureCookie with key into injectable payload+encodeSecureCookie :: (MonadIO m, Serialize t)+                    => Key            -- ^ Encryption key+                    -> SecureCookie t -- ^ Payload+                    -> m ByteString+encodeSecureCookie key (t, val) =+    liftIO $ encryptIO key . encode $ (seconds, val)+  where+    seconds = round (utcTimeToPOSIXSeconds t) :: Integer+++------------------------------------------------------------------------------+-- | Expire secure cookie+expireSecureCookie :: MonadSnap m+                   => ByteString       -- ^ Cookie name+                   -> Maybe ByteString -- ^ Cookie domain+                   -> m ()+expireSecureCookie name domain = expireCookie cookie+  where+    cookie = Cookie name "" Nothing domain (Just "/") False False+++------------------------------------------------------------------------------+-- | Validate session against timeout policy.+--+-- * If timeout is set to 'Nothing', never trigger a time-out.+--+-- * Otherwise, do a regular time-out check based on current time and given+--   timestamp.+checkTimeout :: (MonadSnap m) => Maybe Int -> UTCTime -> m Bool+checkTimeout Nothing _ = return False+checkTimeout (Just x) t0 = do+    t1 <- liftIO getCurrentTime+    return $ t1 > addUTCTime (fromIntegral x) t0
+ src/Snap/Snaplet/Session/SessionManager.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ExistentialQuantification #-}++{-| This module is meant to be used mainly by Session backend+developers, who would naturally need access to ISessionManager class+internals. You can also use it if you need low-level access to the+backend functionality.-}++module Snap.Snaplet.Session.SessionManager where++-------------------------------------------------------------------------------+import           Data.Text (Text)+import           Prelude   hiding (lookup)+-------------------------------------------------------------------------------+import           Snap.Core (Snap)+-------------------------------------------------------------------------------++++-- | Any Haskell record that is a member of the 'ISessionManager'+-- typeclass can be stuffed inside a 'SessionManager' to enable all+-- session-related functionality.+--+-- To use sessions in your application, just find a Backend that would+-- produce one for you inside of your 'Initializer'. See+-- 'initCookieSessionManager' in+-- 'Snap.Snaplet.Session.Backends.CookieSession' for a built-in option+-- that would get you started.+data SessionManager = forall a. ISessionManager a => SessionManager a+++class ISessionManager r where++  -- | Load a session from given payload.+  --+  -- Will always be called before any other operation. If possible, cache and+  -- do nothing when called multiple times within the same request cycle.+  load :: r -> Snap r++  -- | Commit session, return a possibly updated paylaod+  commit :: r -> Snap ()++  -- | Reset session+  reset :: r -> Snap r++  -- | Touch session+  touch :: r -> r++  -- | Insert a key-value pair into session+  insert :: Text -> Text -> r -> r++  -- | Lookup a key in session+  lookup :: Text -> r -> (Maybe Text)++  -- | Delete a key in session+  delete :: Text -> r -> r++  -- | Return a session-specific CSRF protection token. See 'mkCSRFToken' for+  -- help in creating the value.+  csrf :: r -> Text++  -- | Return all key-value pairs as an association list+  toList :: r -> [(Text,Text)]+
+ 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,105 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Main where---------------------------------------------------------------------------------import           Char-import           Data.List-import qualified Data.ByteString.Char8 as S-import qualified Data.Text as T-import           Snap.Http.Server (snapServerVersion)-import           System-import           System.Directory-import           System.Console.GetOpt-import           System.FilePath---------------------------------------------------------------------------------import Snap.StarterTH------------------------------------------------------------------------------------ Creates a value tDir :: ([String], [(String, String)])-$(buildData "tDirBareBones" "barebones")-$(buildData "tDirDefault"   "default")---------------------------------------------------------------------------------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"-    ]----------------------------------------------------------------------------------data InitFlag = InitBareBones-              | InitHelp-              | InitExtensions-  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, _, [])-        | InitHelp `elem` flags -> do putStrLn initUsage-                                      exitFailure-        | otherwise             -> init' flags--      (_, _, errs) -> do putStrLn $ concat errs-                         putStrLn initUsage-                         exitFailure-  where-    initUsage = usageInfo "Usage\n  snap init\n\nOptions:" options--    options =-        [ Option ['b'] ["barebones"]  (NoArg InitBareBones)-                 "Depend only on -core and -server"-        , Option ['h'] ["help"]       (NoArg InitHelp)-                 "Print this message"-        , Option ['e'] ["extensions"] (NoArg InitExtensions)-                 "Depend on snap w/ extensions (default)"-        ]--    init' flags = do-        cur <- getCurrentDirectory-        let dirs = splitDirectories cur-            projName = last dirs-            setup' = setup projName-        case flags of-          (_:_) | InitBareBones  `elem` flags -> setup' tDirBareBones-                | InitExtensions `elem` flags -> setup' tDirDefault-          _                                   -> setup' tDirDefault----------------------------------------------------------------------------------main :: IO ()-main = do-    args <- getArgs-    case args of-        ("init":args') -> initProject args'-        _              -> do putStrLn usage-                             exitFailure
− src/Snap/StarterTH.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Snap.StarterTH where---------------------------------------------------------------------------------import qualified Data.Foldable as F-import           Data.List-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import           System.Directory.Tree------------------------------------------------------------------------------------------------------------------------------------------------------------------- Convenience types-type FileData = (String, String)-type DirData = FilePath------------------------------------------------------------------------------------ Gets all the directorys in a DirTree-getDirs :: [FilePath] -> DirTree a -> [FilePath]-getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) :-                           concatMap (getDirs (n:prefix)) c-getDirs _ (File _ _) = []-getDirs _ (Failed _ _) = []------------------------------------------------------------------------------------ Reads a directory and returns a tuple of the list of all directories--- encountered and a list of filenames and content strings.-readTree :: FilePath -> IO ([DirData], [FileData])-readTree dir = do-    d <- readDirectory $ dir ++ "/."-    let ps = zipPaths $ "" :/ (free d)-        fd = F.foldr (:) [] ps-        dirs = tail . getDirs [] $ free d--    return (dirs, fd)------------------------------------------------------------------------------------ Calls readTree and returns it's value in a quasiquote.-dirQ :: FilePath -> Q Exp-dirQ tplDir = do-    d <- runIO . readTree $ "project_template/" ++ tplDir-    lift d------------------------------------------------------------------------------------ Creates a declaration assigning the specified name the value returned by--- dirQ.-buildData :: String -> FilePath -> Q [Dec]-buildData dirName tplDir = do-    let dir = mkName dirName--    typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |]-    v <- valD (varP dir) (normalB $ dirQ tplDir) []-    return [typeSig, v]
+ test/bad.tpl view
@@ -0,0 +1,1 @@+<bad template
+ test/db.cfg view
@@ -0,0 +1,2 @@+dbServer = "localhost"+dbPort = 1234
+ test/devel.cfg view
@@ -0,0 +1,5 @@+topConfigField = "topConfigValue"++db {+import "db.cfg"+}
+ test/good.tpl view
@@ -0,0 +1,1 @@+Good template
− test/runTests.sh 
@@ -1,21 +0,0 @@-#!/bin/sh--set -e--if [ -z "$DEBUG" ]; then-    export DEBUG=testsuite-fi--SUITE=./dist/build/testsuite/testsuite--if [ ! -f $SUITE ]; then-    cat <<EOF-Testsuite executable not found, please run:-    cabal configure -ftest-then-    cabal build-EOF-    exit;-fi--./dist/build/testsuite/testsuite -j1 $*
− test/snap-testsuite.cabal 
@@ -1,24 +0,0 @@-name:           snap-testsuite-version:        0.0.1-build-type:     Simple-cabal-version:  >= 1.6--Executable testsuite-  hs-source-dirs:  suite-  main-is:         TestSuite.hs--  build-depends:-    QuickCheck >= 2.3.0.2,-    base >= 4 && < 5,-    bytestring == 0.9.*,-    directory,-    filepath,-    HUnit >= 1.2 && < 2,-    http-enumerator >= 0.2.1.5 && <0.3,-    process == 1.*,-    test-framework >= 0.3.1 && <0.4,-    test-framework-hunit >= 0.2.5 && < 0.3,-    test-framework-quickcheck2 >= 0.2.6 && < 0.3-    -  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded-               -fno-warn-unused-do-bind
+ test/snaplets/baz/devel.cfg view
@@ -0,0 +1,2 @@+barSnapletField = "barValue"+
+ test/snaplets/baz/templates/bazconfig.tpl view
@@ -0,0 +1,1 @@+baz config page <appconfig/> <fooconfig/>
+ test/snaplets/baz/templates/bazpage.tpl view
@@ -0,0 +1,1 @@+baz template page <barsplice/>
+ test/snaplets/embedded/extra-templates/extra.tpl view
@@ -0,0 +1,1 @@+This is an extra template
+ test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl view
@@ -0,0 +1,1 @@+embedded snaplet page <asplice/>
+ test/snaplets/foosnaplet/devel.cfg view
@@ -0,0 +1,2 @@+fooSnapletField = "fooValue"+
+ test/snaplets/foosnaplet/templates/foopage.tpl view
@@ -0,0 +1,1 @@+foo template page
+ test/snaplets/heist/templates/_foopage.tpl view
@@ -0,0 +1,7 @@+<html>+  <head></head>+  <body>+    <p>An underscore template.</p>+    <someSplice/>+  </body>+</html>
+ test/snaplets/heist/templates/extraTemplates/barpage.tpl view
@@ -0,0 +1,4 @@+<html>+<head></head>+<body>Hi. Bar.</body>+</html>
+ test/snaplets/heist/templates/foopage.tpl view
@@ -0,0 +1,6 @@+<html>+  <head></head>+  <body>Hi.+    <aSplice/>+  </body>+</html>
+ test/snaplets/heist/templates/index.tpl view
@@ -0,0 +1,1 @@+index page
+ test/snaplets/heist/templates/page.tpl view
@@ -0,0 +1,8 @@+<html>+<head>+<title>Example App</title>+</head>+<body>+<apply-content/>+</body>+</html>
+ test/snaplets/heist/templates/session.tpl view
@@ -0,0 +1,1 @@+<session/>
+ test/snaplets/heist/templates/splicepage.tpl view
@@ -0,0 +1,1 @@+splice page <appsplice/>
+ test/snaplets/heist/templates/userpage.tpl view
@@ -0,0 +1,50 @@+<html>++  <head></head>++  <body>++    <userSplice>+      <h2>+	<ifLoggedIn>+	  <loggedInUser/> is logged in+	</ifLoggedIn>+	+	<ifLoggedOut>+	  You are not logged in+	</ifLoggedOut>+      </h2>++      <h3>loggedInUser: <loggedInUser/></h3>++      <p>UserID <userId/></p>++      <p>UserLogin <userLogin/></p>+      +      <p>UserEmail <userEmail/></p>++      <p>UserActive <userActive/></p>+      +      <p>UserLoginCount <userLoginCount/></p>+      +      <p>UserFailedCount <userFailedCount/></p>+      +      <p>UserLoginAt <userLoginAt/></p>+      +      <p>UserLastLoginAt <userLastLoginAt/></p>+      +      <p>UserSuspendedAt <userSuspendedAt/></p>+      +      <p>UserLoginIP <userLoginIP/></p>+      +      <p>UserLastLoginIP <userLastLoginIP/></p>+      +      <p>UserIfActive <userIfActive/></p>+      +      <p>userIfSuspended <userIfSuspended/></p>+      +    </userSplice>+    +  </body>+  +</html>
+ test/suite/Blackbox/Tests.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Blackbox.Tests+  ( tests+  , remove+  , removeDir+  ) where++------------------------------------------------------------------------------+import           Control.Exception              (catch, finally, throwIO)+import           Control.Monad+import           Control.Monad.Trans+import qualified Data.ByteString.Char8          as S+import qualified Data.ByteString.Lazy.Char8     as L+import           Data.Monoid+import           Data.Text.Lazy                 (Text)+import qualified Data.Text.Lazy                 as T+import qualified Data.Text.Lazy.Encoding        as T+import           Network.Http.Client+import           Prelude                        hiding (catch)+import           System.Directory+import           System.FilePath+import           Test.Framework                 (Test, testGroup)+import           Test.Framework.Providers.HUnit+import           Test.HUnit                     hiding (Test, path)+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+testServer :: String+testServer = "http://127.0.0.1"+++------------------------------------------------------------------------------+testPort :: String+testPort = "9753"+++------------------------------------------------------------------------------+-- | The server uri, without the leading slash.+testServerUri :: String+testServerUri = testServer ++ ":" ++ testPort+++------------------------------------------------------------------------------+-- | The server url, with the leading slash.+testServerUrl :: String+testServerUrl = testServerUri ++ "/"+++                            --------------------+                            --  TEST LOADER   --+                            --------------------++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "non-cabal-tests"+    [ requestTest "hello" "hello world"+    , requestTest "index" "index page\n"+    , requestTest "" "index page\n"+    , requestTest "splicepage" "splice page contents of the app splice\n"+    , requestTest "routeWithSplice" "routeWithSplice: foo snaplet data stringz"+    , requestTest "routeWithConfig" "routeWithConfig: topConfigValue"+    , requestTest "foo/foopage" "foo template page\n"+    , requestTest "foo/fooConfig" "fooValue"+    , requestTest "foo/fooRootUrl" "foo"+    , requestTest "barconfig" "barValue"+    , requestTest "bazpage" "baz template page <barsplice></barsplice>\n"+    , requestTest "bazpage2" "baz template page contents of the bar splice\n"+    , requestTest "bazpage3" "baz template page <barsplice></barsplice>\n"+    , requestTest "bazpage4" "baz template page <barsplice></barsplice>\n"+    , requestTest "barrooturl" "url"+    , requestExpectingErrorPrefix "bazbadpage" 500 "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found."+    , requestTest "foo/fooSnapletName" "foosnaplet"++    , fooConfigPathTest++    -- Test the embedded snaplet+    , requestTest "embed/heist/embeddedpage" "embedded snaplet page <asplice></asplice>\n"+    , requestTest "embed/aoeuhtns" "embedded snaplet page splice value42\n"+    , requestTest "embed/heist/onemoredir/extra" "This is an extra template\n"++    -- This set of tests highlights the differences in the behavior of the+    -- get... functions from MonadSnaplet.+    , fooHandlerConfigTest+    , barHandlerConfigTest+    , bazpage5Test+    , bazConfigTest+    , requestTest "sessionDemo" "[(\"foo\",\"bar\")]\n"+    , reloadTest+    ]+++------------------------------------------------------------------------------+testName :: String -> String+testName uri = "internal/" ++ uri+--testName = id++------------------------------------------------------------------------------+requestTest :: String -> Text -> Test+requestTest url desired = testCase (testName url) $ requestTest' url desired+++------------------------------------------------------------------------------+requestTest' :: String -> Text -> IO ()+requestTest' url desired = do+    actual <- get (S.pack $ testServerUrl ++ url) concatHandler+    assertEqual url desired (T.decodeUtf8 $ L.fromChunks [actual])+++------------------------------------------------------------------------------+requestExpectingErrorPrefix :: String -> Int -> Text -> Test+requestExpectingErrorPrefix url status desired =+    testCase (testName url) $ requestExpectingErrorPrefix' url status desired+++------------------------------------------------------------------------------+requestExpectingErrorPrefix' :: String -> Int -> Text -> IO ()+requestExpectingErrorPrefix' url status desired = do+    let fullUrl = testServerUrl ++ url+    get (S.pack fullUrl) $ \resp is -> do+      assertEqual ("Status code: "++fullUrl) status+                  (getStatusCode resp)+      res <- concatHandler resp is+      assertBool fullUrl $ desired `T.isPrefixOf` (T.decodeUtf8 $ L.fromChunks [res])+++------------------------------------------------------------------------------+fooConfigPathTest :: Test+fooConfigPathTest = testCase (testName "foo/fooFilePath") $ do+    b <- liftM L.unpack $ grab "/foo/fooFilePath"+    assertRelativelyTheSame b "snaplets/foosnaplet"+++------------------------------------------------------------------------------+assertRelativelyTheSame :: FilePath -> FilePath -> IO ()+assertRelativelyTheSame p expected = do+    b <- makeRelativeToCurrentDirectory p+    assertEqual ("expected " ++ expected) expected b+++------------------------------------------------------------------------------+grab :: MonadIO m => String -> m L.ByteString+grab path = liftIO $ liftM (L.fromChunks . (:[])) $+  get (S.pack $ testServerUri ++ path) concatHandler+++------------------------------------------------------------------------------+testWithCwd :: String+            -> (String -> L.ByteString -> Assertion)+            -> Test+testWithCwd uri f = testCase (testName uri) $+                    testWithCwd' uri f+++------------------------------------------------------------------------------+testWithCwd' :: String+             -> (String -> L.ByteString -> Assertion)+             -> Assertion+testWithCwd' uri f = do+    b   <- grab slashUri+    cwd <- getCurrentDirectory++    f cwd b++  where+    slashUri = '/' : uri+++------------------------------------------------------------------------------+fooHandlerConfigTest :: Test+fooHandlerConfigTest = testWithCwd "foo/handlerConfig" $ \cwd b -> do+    let response = L.fromChunks [ "([\"app\"],\""+                                , S.pack cwd+                                , "/snaplets/foosnaplet\","+                                , "Just \"foosnaplet\",\"A demonstration "+                                , "snaplet called foo.\",\"foo\")" ]+    assertEqual "" response b+++------------------------------------------------------------------------------+barHandlerConfigTest :: Test+barHandlerConfigTest = testWithCwd "bar/handlerConfig" $ \cwd b -> do+    let response = L.fromChunks [ "([\"app\"],\""+                                , S.pack cwd+                                , "/snaplets/baz\","+                                , "Just \"baz\",\"An example snaplet called "+                                , "bar.\",\"\")" ]+    assertEqual "" response b+++------------------------------------------------------------------------------+-- bazpage5 uses barsplice bound by renderWithSplices at request time+bazpage5Test :: Test+bazpage5Test = testWithCwd "bazpage5" $ \cwd b -> do+    let response = L.fromChunks [ "baz template page ([\"app\"],\""+                                , S.pack cwd+                                , "/snaplets/baz\","+                                , "Just \"baz\",\"An example snaplet called "+                                , "bar.\",\"\")\n" ]+    assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b)+++------------------------------------------------------------------------------+-- bazconfig uses two splices, appconfig and fooconfig. appconfig is bound with+-- the non type class version of addSplices in the main app initializer.+-- fooconfig is bound by addSplices in fooInit.+bazConfigTest :: Test+bazConfigTest = testWithCwd "bazconfig" $ \cwd b -> do+    let response = L.fromChunks [+                     "baz config page ([],\""+                   , S.pack cwd+                   , "\",Just \"app\"," -- TODO, right?+                   , "\"Test application\",\"\") "+                   , "([\"app\"],\""+                   , S.pack cwd+                   , "/snaplets/foosnaplet\","+                   , "Just \"foosnaplet\",\"A demonstration snaplet "+                   , "called foo.\",\"foo\")\n"+                   ]++    assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b)+++------------------------------------------------------------------------------+expect404 :: String -> IO ()+expect404 url = do+    get (S.pack $ testServerUrl ++ url) $ \resp i -> do+        case getStatusCode resp of+          404 -> return ()+          _   -> assertFailure "expected 404"+++------------------------------------------------------------------------------+request404Test :: String -> Test+request404Test url = testCase (testName url) $ expect404 url+++remove :: FilePath -> IO ()+remove f = do+    exists <- doesFileExist f+    when exists $ removeFile f+++removeDir :: FilePath -> IO ()+removeDir d = do+    exists <- doesDirectoryExist d+    when exists $ removeDirectoryRecursive "snaplets/foosnaplet"+++------------------------------------------------------------------------------+reloadTest :: Test+reloadTest = testCase "internal/reload-test" $ do+    let goodTplOrig = "good.tpl"+    let badTplOrig  = "bad.tpl"+    let goodTplNew  = "snaplets"  </> "heist"+                      </> "templates" </> "good.tpl"+    let badTplNew   = "snaplets"  </> "heist"+                      </> "templates" </> "bad.tpl"++    goodExists <- doesFileExist goodTplNew+    badExists  <- doesFileExist badTplNew++    assertBool "good.tpl exists" (not goodExists)+    assertBool "bad.tpl exists"  (not badExists)+    expect404 "bad"++    copyFile badTplOrig badTplNew+    expect404 "good"+    expect404 "bad"++    flip finally (remove badTplNew) $+      testWithCwd' "admin/reload" $ \cwd' b -> do+        let cwd = T.pack cwd'++        let prefix = T.intercalate "\n"+              [ "Error reloading site!"+              , ""+              , "Initializer threw an exception..."+              , T.concat+                [ cwd, "/snaplets/heist/templates/bad.tpl \""+                , cwd, "/snaplets/heist/templates/bad.tpl\" (line 2, column 1):"+                ]+              , "unexpected end of input"+              , "expecting \"=\", \"/\" or \">\""++              -- Building with the latest dependency versions produces the following:+              -- "CallStack (from HasCallStack):"+              -- "  error, called at src/Snap/Snaplet/Heist/Internal.hs:75:35 in main:Snap.Snaplet.Heist.Internal"+              ]++        let suffix = T.intercalate "\n"+              [ "...but before it died it generated the following output:"+              , "Initializing app @ /"+              , "Initializing heist @ /heist"+              , ""+              , ""+              ]++        let response = T.decodeUtf8 b++        assertEqual "admin/reload" prefix (T.take    (T.length prefix) response)+        assertEqual "admin/reload" suffix (T.takeEnd (T.length suffix) response)++    copyFile goodTplOrig goodTplNew++    testWithCwd' "admin/reload" $ \cwd' b -> do  -- TODO/NOTE: Needs cleanup+        let cwd = S.pack cwd'+        let response = L.fromChunks [+              "Initializing app @ /\nInitializing heist @ ",+              "/heist\n...loaded 9 templates from ",+              cwd,+              "/snaplets/heist/templates\nInitializing CookieSession ",+              "@ /session\nInitializing foosnaplet @ /foo\n...adding 1 ",+              "templates from ",+              cwd,+              "/snaplets/foosnaplet/templates with route prefix ",+              "foo/\nInitializing baz @ /\n...adding 2 templates from ",+              cwd,+              "/snaplets/baz/templates with route prefix /\nInitializing ",+              "embedded @ /\nInitializing heist @ /heist\n...loaded ",+              "1 templates from ",+              cwd,+              "/snaplets/embedded/snaplets/heist/templates\n...adding ",+              "1 templates from ",+              cwd,+              "/snaplets/embedded/extra-templates with route prefix ",+              "onemoredir/\n...adding 0 templates from ",+              cwd,+              "/templates with route prefix extraTemplates/\n",+              "Initializing JsonFileAuthManager @ ",+              "/auth\nSite successfully reloaded.\n"+              ]++        assertEqual "admin/reload" response b++    requestTest' "good" "Good template\n"++
+ test/suite/SafeCWD.hs view
@@ -0,0 +1,33 @@+module SafeCWD+  ( inDir+  , removeDirectoryRecursiveSafe+  ) where++import Control.Concurrent.QSem+import Control.Exception+import Control.Monad+import System.Directory+import System.IO.Unsafe++sem :: QSem+sem = unsafePerformIO $ newQSem 1+{-# NOINLINE sem #-}+++inDir :: Bool -> FilePath -> IO a -> IO a+inDir startClean dir action = bracket before after (const action)+  where+    before = do+        waitQSem sem+        cwd <- getCurrentDirectory+        when startClean $ removeDirectoryRecursiveSafe dir+        createDirectoryIfMissing True dir+        setCurrentDirectory dir+        return cwd+    after cwd = do+        setCurrentDirectory cwd+        signalQSem sem+++removeDirectoryRecursiveSafe p =+    doesDirectoryExist p >>= flip when (removeDirectoryRecursive p)
+ test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs view
@@ -0,0 +1,729 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.Auth.Handlers.Tests+  ( tests ) where+++------------------------------------------------------------------------------+import           Control.Applicative+import           Control.Monad.State            as S+import           Control.Monad.Trans.Maybe      (MaybeT(..), runMaybeT)+import qualified Data.Map                       as Map+import           Data.Maybe                     (isJust, isNothing)+import           Data.Time.Clock                (diffUTCTime, getCurrentTime)+import           Test.Framework                 (Test, mutuallyExclusive,+                                                 testGroup)+import           Test.Framework.Providers.HUnit (testCase)+import           Test.HUnit                     hiding (Test, path)+++------------------------------------------------------------------------------+import           Snap.Core                      (writeText)+import           Snap.Snaplet                   (Handler, with)+import           Snap.Snaplet.Auth              (AuthUser(..),+                                                 AuthFailure(..),+                                                 Password(..), Role(..))+import qualified Snap.Snaplet.Auth              as A+import           Snap.Snaplet.Test.Common.App   (App, appInit, appInit',+                                                 auth)+import qualified Snap.Test                      as ST+import           Snap.Snaplet.Test              (evalHandler, runHandler,+                                                 withTemporaryFile)+++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Snap.Snaplet.Auth.Handlers"+    [mutuallyExclusive $ testGroup "createUser tests"+        [ testCreateUserGood+        , testWithCfgFile+        , testCreateUserTimely+        , testCreateUserWithRole+        , testCreateEmptyUser+        , testCreateDupUser+        , testUsernameExists +        , testLoginByUsername +        , testLoginByUsernameEnc+        , testLoginByUsernameNoU +        , testLoginByUsernameInvPwd+        , testLoginByRememberTokenKO+        , testLoginByRememberTokenOK+        , testLogoutKO+        , testLogoutOK+        , testCurrentUserKO+        , testCurrentUserOK+        , testIsLoggedInKO+        , testIsLoggedInOK+        , testSaveUserKO+        , testSaveUserOK+        , testMarkAuthFail+        --, testMarkAuthFailLockedOut+        , testMarkAuthSuccess+        , testCheckPasswordAndLoginOK+        , testCheckPasswordAndLoginKO+        , testAuthenticatePasswordOK+        , testAuthenticatePasswordPwdMissing+        , testAuthenticatePasswordPwdWrong+        , testRegisterUserOK+        , testRegisterUserNoUser+        , testRegisterUserNoPwd+        , testRequireUserOK+        , testRequireUserKO+        ]+    ]++------------------------------------------------------------------------------+isJustFailure :: AuthFailure -> Maybe AuthFailure -> Bool+isJustFailure failure (Just expected) = failure == expected+isJustFailure _ _ = False+++------------------------------------------------------------------------------+isLeftFailure :: AuthFailure -> Either AuthFailure AuthUser -> Bool+isLeftFailure failure (Left expected) = failure == expected+isLeftFailure _ _ = False+++------------------------------------------------------------------------------+testCreateUserGood :: Test+testCreateUserGood = testCase "createUser good params" assertGoodUser+  where +    assertGoodUser :: Assertion+    assertGoodUser = withTemporaryFile "users.json" $ do+        let hdl = with auth $ A.createUser "foo" "foo"+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isRight) res++    failMsg = "createUser failed: Couldn't create a new user."+++------------------------------------------------------------------------------+testWithCfgFile :: Test+testWithCfgFile = testCase "createUser with config file settings" assertCfg+  where+    assertCfg :: Assertion+    assertCfg = withTemporaryFile "users.json" $ do+      let hdl = with auth $ A.createUser "foo" "foo"+      res <- runHandler Nothing (ST.get "" Map.empty) hdl+             (appInit' False True)+      either (assertFailure . show) ST.assertSuccess res+++------------------------------------------------------------------------------+testCreateUserTimely :: Test+testCreateUserTimely = testCase "createUser good updatedAt" assertCreateTimely+  where+    assertCreateTimely :: Assertion+    assertCreateTimely = withTemporaryFile "users.json" $ do+      let hdl = with auth $ A.createUser "foo" "foo"+      tNow <- getCurrentTime+      let isTimely t' = maybe False (\t -> diffUTCTime tNow t < 1) t'+      res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+      case res of+        Left  e          -> assertFailure . show $ e+        Right (Left e)   -> assertFailure . show $ e+        Right (Right au) -> assertBool failMsg $ isTimely (userUpdatedAt au)+                            && isTimely (userCreatedAt au)++    failMsg = "createUser: userUpdatedAt, userCreatetAt times not set"+++hush :: Either e a -> Maybe a+hush (Left _) = Nothing+hush (Right a) = Just a++------------------------------------------------------------------------------+testCreateUserWithRole :: Test+testCreateUserWithRole = testCase "createUser with role" assertUserRole+  where+    assertUserRole :: Assertion+    assertUserRole = withTemporaryFile "users.json" $ do+      let hdl = with auth $ runMaybeT $ do+            u <- MaybeT $ hush <$> A.createUser "foo" "foo"+            _ <- MaybeT $ hush <$>+                 A.saveUser (u {userRoles = [Role "admin",Role "user"]})+            MaybeT $ hush <$> A.loginByUsername "foo" (ClearText "foo") False+      res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+      case res of+        Left e           -> assertFailure $ show e+        Right Nothing    -> assertFailure "Failed saved user lookup"+        Right (Just usr) -> assertEqual "Roles don't match expectation"+                         [Role "admin",Role "user"]+                         (userRoles usr)+++------------------------------------------------------------------------------+testCreateEmptyUser :: Test+testCreateEmptyUser = testCase "createUser empty username" assertEmptyUser+  where +    assertEmptyUser :: Assertion+    assertEmptyUser = do+        let hdl = with auth $ A.createUser "" "foo"+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show)+               (assertBool failMsg . isLeftFailure UsernameMissing) res++    failMsg = "createUser: Was created an empty username despite they aren't allowed."+++------------------------------------------------------------------------------+-- Is the tests execution order garanteed? When this runs, the user "foo"+-- will be already present in the backend.+testCreateDupUser :: Test+testCreateDupUser = testCase "createUser duplicate user" assertDupUser+  where +    assertDupUser :: Assertion+    assertDupUser = do+        let hdl = with auth $ A.createUser "foo" "foo"+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show)+               (assertBool failMsg . isLeftFailure DuplicateLogin) res++    failMsg = "createUser: Expected to find a duplicate user, but I haven't."+++------------------------------------------------------------------------------+-- A non desirable thing is to be couple by the temporal execution of+-- tests. The problem has been resolved using fixtures, so something like+-- that would be beneficial for next releases.+testUsernameExists :: Test+testUsernameExists = testCase "username exists" assertUserExists+  where+    assertUserExists :: Assertion+    assertUserExists = do+        let hdl = with auth $ A.usernameExists "foo"+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg) res++    failMsg = "usernameExists: Expected to return True, but it didn't."+++------------------------------------------------------------------------------+testLoginByUsername :: Test+testLoginByUsername = testCase "successful loginByUsername" assertion+  where+    assertion :: Assertion+    assertion = do+        let pwd = ClearText "foo"+        res <- evalHandler Nothing (ST.get "" Map.empty) (loginByUnameHdlr pwd) appInit+        either (assertFailure . show) (assertBool failMsg . isRight) res++    failMsg = "loginByUsername: Failed with ClearText pwd."+++------------------------------------------------------------------------------+-- Reused below.+loginByUnameHdlr :: Password -> Handler App App (Either AuthFailure AuthUser)+loginByUnameHdlr pwd = with auth $ A.loginByUsername "foo" pwd False+++------------------------------------------------------------------------------+testLoginByUsernameEnc :: Test+testLoginByUsernameEnc = testCase "loginByUsername encrypted pwd" assertion+  where+    assertion :: Assertion+    assertion = do+        let pwd = Encrypted "foo"+        res <- evalHandler Nothing (ST.get "" Map.empty) (loginByUnameHdlr pwd) appInit+        either (assertFailure . show)+               (assertBool failMsg . isLeftFailure EncryptedPassword) res++    failMsg = "loginByUsername: Expected to find an Encrypted password, but I haven't."+++------------------------------------------------------------------------------+testLoginByUsernameNoU :: Test+testLoginByUsernameNoU = testCase "loginByUsername invalid user" assertion+  where+    assertion :: Assertion+    assertion = do+        let pwd = ClearText "foo"+        let hdl = with auth $ A.loginByUsername "doesnotexist" pwd False+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show)+               (assertBool failMsg . isLeftFailure UserNotFound) res++    failMsg = "loginByUsername: Expected to fail for an invalid user, but I didn't."+++------------------------------------------------------------------------------+testLoginByUsernameInvPwd :: Test+testLoginByUsernameInvPwd = testCase "loginByUsername invalid user" assertion+  where+    assertion :: Assertion+    assertion = do+        let pwd = ClearText "invalid"+        let hdl = with auth $ A.loginByUsername "foo" pwd False+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isLeft) res++    failMsg = "loginByUsername: Expected to fail for an invalid pwd, but I didn't."+++------------------------------------------------------------------------------+testLoginByRememberTokenKO :: Test+testLoginByRememberTokenKO = testCase "loginByRememberToken no token" assertion+  where+    assertion :: Assertion+    assertion = do+        let hdl = with auth A.loginByRememberToken+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isLeft) res++    failMsg = "loginByRememberToken: Expected to fail for the " +++              "absence of a token, but I didn't."+++------------------------------------------------------------------------------+testLoginByRememberTokenOK :: Test+testLoginByRememberTokenOK = testCase "loginByRememberToken token" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        case res of+          (Left e) -> assertFailure $ show e+          (Right res') -> assertBool failMsg $ isRight res'++    hdl :: Handler App App (Either AuthFailure AuthUser)+    hdl = with auth $ do+        res <- A.loginByUsername "foo" (ClearText "foo") True+        either (\e -> return (Left e)) (\_ -> A.loginByRememberToken) res++    failMsg = "loginByRememberToken: Expected to succeed but I didn't."+++------------------------------------------------------------------------------+testLogoutKO :: Test+testLogoutKO = testCase "logout no user logged in." $ assertLogout hdl failMsg+  where+    hdl :: Handler App App (Maybe AuthUser)+    hdl = with auth $ do+        A.logout+        mgr <- S.get+        return (A.activeUser mgr)++    failMsg = "logout: Expected to get Nothing as the active user, " +++              " but I didn't."+++------------------------------------------------------------------------------+assertLogout :: Handler App App (Maybe AuthUser) -> String -> Assertion+assertLogout hdl failMsg = do+    res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+    either (assertFailure . show) (assertBool failMsg . isNothing) res+++------------------------------------------------------------------------------+testLogoutOK :: Test+testLogoutOK = testCase "logout user logged in." $ assertLogout hdl failMsg+  where+    hdl :: Handler App App (Maybe AuthUser)+    hdl = with auth $ do+        _ <- A.loginByUsername "foo" (ClearText "foo") True+        A.logout+        mgr <- get+        return (A.activeUser mgr)++    failMsg = "logout: Expected to get Nothing as the active user, " +++              " but I didn't."+++------------------------------------------------------------------------------+testCurrentUserKO :: Test+testCurrentUserKO = testCase "currentUser unsuccesful call" assertion+  where+    assertion :: Assertion+    assertion = do+        let hdl = with auth A.currentUser+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isNothing) res++    failMsg = "currentUser: Expected Nothing as the current user, " +++              " but I didn't."+++------------------------------------------------------------------------------+testCurrentUserOK :: Test+testCurrentUserOK = testCase "successful currentUser call" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isJust) res++    hdl :: Handler App App (Maybe AuthUser)+    hdl = with auth $ do+        res <- A.loginByUsername "foo" (ClearText "foo") True+        either (\_ -> return Nothing) (\_ -> A.currentUser) res++    failMsg = "currentUser: Expected to get the current user, " +++              " but I didn't."+++------------------------------------------------------------------------------+testIsLoggedInKO :: Test+testIsLoggedInKO = testCase "isLoggedIn, no user logged" assertion+  where+    assertion :: Assertion+    assertion = do+        let hdl = with auth A.isLoggedIn+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . not) res++    failMsg = "isLoggedIn: Expected False, but got True."+++------------------------------------------------------------------------------+testIsLoggedInOK :: Test+testIsLoggedInOK = testCase "isLoggedIn, user logged" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg) res++    hdl :: Handler App App Bool+    hdl = with auth $ do+        _ <- A.loginByUsername "foo" (ClearText "foo") True+        A.isLoggedIn++    failMsg = "isLoggedIn: Expected True, but got False."+++------------------------------------------------------------------------------+-- It fails because destroy is not yet implemented for the Json backend.+testDestroyUser :: Test+testDestroyUser = testCase "destroyUser" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . not) res++    hdl :: Handler App App Bool+    hdl = with auth $ do+        newUser <- A.createUser "bar" "bar"+        either (\_ -> return True)+               (\u -> A.destroyUser u >> A.usernameExists "bar")+               newUser++    failMsg = "destroyUser: I've tried to destroy an existing user, " +++              "but user is still there."+++------------------------------------------------------------------------------+testSaveUserKO :: Test+testSaveUserKO = testCase "saveUser null username" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isLeft) res++    hdl :: Handler App App (Either AuthFailure AuthUser)+    hdl = with auth $ do+        user <- A.loginByUsername "foo" (ClearText "foo") True+        case user of+          (Left e) -> return $ Left e+          (Right u) -> A.saveUser (u { userLogin = "" })++    failMsg = "saveUser: I expected to fail since I'm saving an " +++              "empty username, but I didn't."+++------------------------------------------------------------------------------+-- Trying to update a Cleartext text pwd result in an error. Feature or+-- bug? (error: Json can't serialize ClearText pwd)+testSaveUserOK :: Test+testSaveUserOK = testCase "saveUser good update params" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isRight) res++    hdl :: Handler App App (Either AuthFailure AuthUser)+    hdl = with auth $ do+        user <- A.loginByUsername "foo" (ClearText "foo") True+        case user of+          (Left e) -> return $ Left e+          (Right u) -> A.saveUser (u { userLoginCount = 99 })++    failMsg = "saveUser: I expected to success since I'm saving a " +++              "valid user, but I didn't."+++------------------------------------------------------------------------------+testMarkAuthFail :: Test+testMarkAuthFail = testCase "successful markAuthFail call" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg) res++    -- Lot of destructuring here, but the idea is to test if+    -- failedLoginCount increased by 1.+    hdl :: Handler App App Bool+    hdl = with auth $ do+        user <- A.loginByUsername "foo" (ClearText "foo") True+        case user of+          (Left _) -> return False+          (Right u) ->+              let failCount = userFailedLoginCount u+                  in do+                      res <- A.markAuthFail u+                      either (\_ -> return False)+                             (\u' -> return $+                                    userFailedLoginCount u' == failCount + 1)+                             res++    failMsg = "markAuthFail: I expected to increase the userFailedLoginCount, " +++              "but I didn't."+++------------------------------------------------------------------------------+testMarkAuthFailLockedOut :: Test+testMarkAuthFailLockedOut = testCase "markAuthFail lockedOut" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isLockedOut) res++    hdl :: Handler App App (Either AuthFailure AuthUser)+    hdl = with auth $ do+        user <- A.loginByUsername "bar" (ClearText "bar") True+        case user of+          (Left e) -> return $ Left e+          (Right u) ->+              let u' = u {userFailedLoginCount = 99}+                  in do+                      modify (\s -> s { A.lockout = Just (5, 1000000) })+                      A.markAuthFail u'++    failMsg = "markAuthFail: I expected the user to be LockedOut, " +++              "but he didn't."++    isLockedOut :: Either AuthFailure AuthUser -> Bool+    isLockedOut (Left _) = False+    isLockedOut (Right u) = isJust $ userLockedOutUntil u++------------------------------------------------------------------------------+testMarkAuthSuccess :: Test+testMarkAuthSuccess = testCase "successful markAuthSuccess call" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg) res++    hdl :: Handler App App Bool+    hdl = with auth $ do+        user <- A.loginByUsername "foo" (ClearText "foo") True+        case user of+          (Left _) -> return False+          (Right u) ->+              let count = userLoginCount u+                  in do+                      res <- A.markAuthSuccess u+                      either (\_ -> return False)+                             (\u' -> return $+                                    userLoginCount u' == count + 1)+                             res++    failMsg = "markAuthSuccess: I expected to increase the userLoginCount, " +++              "but I didn't."+++------------------------------------------------------------------------------+testCheckPasswordAndLoginOK :: Test+testCheckPasswordAndLoginOK = testCase "checkPasswordAndLogin OK" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isRight) res++    hdl :: Handler App App (Either AuthFailure AuthUser)+    hdl = with auth $ do+        let pwd = ClearText "foo"+        res <- A.loginByUsername "foo" pwd False+        either (return . Left) (`A.checkPasswordAndLogin` pwd) res++    failMsg = "checkPasswordAndLogin: I expected to succeed " +++              "but I didn't."+++------------------------------------------------------------------------------+testCheckPasswordAndLoginKO :: Test+testCheckPasswordAndLoginKO = testCase "checkPasswordAndLogin KO" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isLeft) res++    hdl :: Handler App App (Either AuthFailure AuthUser)+    hdl = with auth $ do+        let pwd = ClearText "wrongpass"+        res <- A.loginByUsername "foo" pwd False+        either (return . Left) (`A.checkPasswordAndLogin` pwd) res++    failMsg = "checkPasswordAndLogin: I expected to succeed " +++              "but I didn't."+++------------------------------------------------------------------------------+testAuthenticatePasswordOK :: Test+testAuthenticatePasswordOK = testCase "authenticatePassword OK" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isNothing) res++    hdl :: Handler App App (Maybe AuthFailure)+    hdl = with auth $ do+        let pwd = ClearText "foo"+        res <- A.loginByUsername "foo" pwd False+        either (return . Just)+               (\u -> return $ A.authenticatePassword u pwd) res++    failMsg = "authenticatePassword: I expected to succeed " +++              "but I didn't."+++------------------------------------------------------------------------------+testAuthenticatePasswordPwdMissing :: Test+testAuthenticatePasswordPwdMissing = testCase "authenticatePassword no pwd" a+  where+    a :: Assertion+    a = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show)+               (assertBool failMsg . isJustFailure PasswordMissing) res++    hdl :: Handler App App (Maybe AuthFailure)+    hdl = with auth $ do+        let pwd = ClearText "foo"+        res <- A.loginByUsername "foo" pwd False+        either (return . Just)+               (\u -> let u' = u { userPassword = Nothing }+                         in return $ A.authenticatePassword u' pwd) res++    failMsg = "authenticatePassword: I expected to fail due to " +++              " MissingPassword, but I didn't."+    ++------------------------------------------------------------------------------+testAuthenticatePasswordPwdWrong :: Test+testAuthenticatePasswordPwdWrong = testCase "authenticatePassword wrong pwd" a+  where+    a :: Assertion+    a = do+        res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show)+               (assertBool failMsg . isJustFailure IncorrectPassword) res++    hdl :: Handler App App (Maybe AuthFailure)+    hdl = with auth $ do+        let pwd = ClearText "foo"+        res <- A.loginByUsername "foo" pwd False+        either (return . Just)+               (return . flip A.authenticatePassword (ClearText "bar")) res++    failMsg = "authenticatePassword: I expected to fail due to " +++              " IncorrectPassword, but I didn't."+++------------------------------------------------------------------------------+testRegisterUserOK :: Test+testRegisterUserOK = testCase "registerUser OK" assertion+  where+    assertion :: Assertion+    assertion = do+        let hdl = with auth $ A.registerUser "user" "pwd"+        let params = Map.fromList [("user", ["fizz"]), ("pwd", ["buzz"])]+        res <- evalHandler Nothing (ST.get "" $ params) hdl appInit+        either (assertFailure . show) (assertBool failMsg . isRight) res++    failMsg = "registerUser: I expected to succeed " +++              ", but I didn't."+++------------------------------------------------------------------------------+testRegisterUserNoUser :: Test+testRegisterUserNoUser = testCase "registerUser no user given" assertion+  where+    assertion :: Assertion+    assertion = do+        let hdl = with auth $ A.registerUser "user" "pwd"+        let params = [("user", []), ("pwd", ["buzz"])]+        res <- evalHandler Nothing (ST.get "" $ Map.fromList params) hdl appInit+        either (assertFailure . show)+               (assertBool failMsg . isLeftFailure UsernameMissing) res++    failMsg = "registerUser: I expected to fail due to UsernameMissing " +++              ", but I didn't."+++------------------------------------------------------------------------------+testRegisterUserNoPwd :: Test+testRegisterUserNoPwd = testCase "registerUser no pwd given" assertion+  where+    assertion :: Assertion+    assertion = do+        let hdl = with auth $ A.registerUser "user" "pwd"+        let params = Map.fromList [("user", ["fizz"]), ("pwd", [])]+        res <- evalHandler Nothing (ST.get "" $ params) hdl appInit+        either (assertFailure . show)+               (assertBool failMsg . isLeftFailure PasswordMissing) res++    failMsg = "registerUser: I expected to fail due to PasswordMissing " +++              ", but I didn't."+++------------------------------------------------------------------------------+testRequireUserOK :: Test+testRequireUserOK = testCase "requireUser good handler exec" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (ST.assertBodyContains "good") res++    hdl :: Handler App App ()+    hdl = with auth $ do+        let badHdl = writeText "bad"+        let goodHdl = writeText "good"+        A.loginByUsername "foo" (ClearText "foo") True+        A.requireUser auth badHdl goodHdl+++------------------------------------------------------------------------------+testRequireUserKO :: Test+testRequireUserKO = testCase "requireUser bad handler exec" assertion+  where+    assertion :: Assertion+    assertion = do+        res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+        either (assertFailure . show) (ST.assertBodyContains "bad") res++    hdl :: Handler App App ()+    hdl = with auth $ do+        let badHdl = writeText "bad"+        let goodHdl = writeText "good"+        _ <- A.loginByUsername "doesnotexist" (ClearText "") True+        A.requireUser auth badHdl goodHdl+++isRight :: Either a b -> Bool+isRight (Left _) = False+isRight (Right _) = True++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft (Right _) = False+
+ test/suite/Snap/Snaplet/Auth/SpliceTests.hs view
@@ -0,0 +1,68 @@+module Snap.Snaplet.Auth.SpliceTests (+  tests+  ) where+++------------------------------------------------------------------------------+import           Control.Monad                  (replicateM_, when)+import qualified Data.Map                       as Map+import qualified Data.ByteString                as BS+import           Test.Framework                 (Test, testGroup)+import           Test.Framework.Providers.HUnit (testCase)+import           Test.HUnit                     hiding (Test)+------------------------------------------------------------------------------+import           Snap.Core                      as Core+import           Snap.Snaplet                   (with)+import qualified Snap.Test                      as ST+import           Snap.Snaplet.Test              (runHandler,+                                                 withTemporaryFile)+import           Snap.Snaplet.Auth              (Password(ClearText),+                                                 createUser, loginByUsername,+                                                 userISplices)+import           Snap.Snaplet.Heist             (cRender, render,+                                                 withSplices)+import           Snap.Snaplet.Test.Common.App   (appInit, auth)+++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Snap.Snaplet.Auth.SpliceHelpers"+        [testCase "Render new user page"    $ renderNewUser False False+        ,testCase "New user login render"   $ renderNewUser True  False+        ,testCase "New user suspend render" $ renderNewUser False True+        ,testCase "cRender new user page"   $ cRenderNewUser+        ]+++------------------------------------------------------------------------------+renderNewUser :: Bool -> Bool -> Assertion+renderNewUser login suspend = withTemporaryFile "users.json" $ do+  let hdl = with auth $ do+        usr <- createUser "foo" "foo"+        _ <- when login $+             loginByUsername "foo" (ClearText "foo") False >> return ()+        _ <- when suspend $ replicateM_ 4 $+             loginByUsername "foo" (ClearText "wrong") False+        either+          (\_ -> Core.modifyResponse $ Core.setResponseStatus 500 "Error")+          (\u -> withSplices (userISplices u) $ render "userpage")+          usr+  res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+  either (assertFailure . show) ST.assertSuccess res+++------------------------------------------------------------------------------+cRenderNewUser :: Assertion+cRenderNewUser = withTemporaryFile "users.json" $ do+  let hdl = with auth $ do+        _ <- createUser "foo" "foo"+        _ <- loginByUsername "foo" (ClearText "foo") True+        cRender "userpage"++      assertValidRes r = do+        rStr <- ST.responseToString r+        assertBool "userpage should contain UserName foo splice" $+          "UserLogin foo" `BS.isInfixOf` rStr++  res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+  either (assertFailure . show) assertValidRes res
+ test/suite/Snap/Snaplet/Auth/Tests.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+++module Snap.Snaplet.Auth.Tests+  ( tests ) where+++------------------------------------------------------------------------------+import           Test.Framework                   (Test, testGroup)+import qualified Snap.Snaplet.Auth.Handlers.Tests+import qualified Snap.Snaplet.Auth.Types.Tests+import qualified Snap.Snaplet.Auth.SpliceTests+++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Snap.Snaplet.Auth"+    [ Snap.Snaplet.Auth.Handlers.Tests.tests+    , Snap.Snaplet.Auth.SpliceTests.tests+    , Snap.Snaplet.Auth.Types.Tests.tests+    ]+
+ test/suite/Snap/Snaplet/Auth/Types/Tests.hs view
@@ -0,0 +1,178 @@+module Snap.Snaplet.Auth.Types.Tests (+  tests+  ) where++------------------------------------------------------------------------------+import           Control.Exception                    (SomeException, evaluate, try)+import           Control.Monad                        (liftM)+import           Data.Aeson                           (decode, eitherDecode, encode)+import qualified Data.ByteString                      as BS+import qualified Data.ByteString.Lazy.Char8           as BSL+import qualified Data.Text                            as T+import           Data.Text.Encoding                   (encodeUtf8)+import           Data.Time+import           Test.Framework                       (Test, testGroup)+import           Test.Framework.Providers.HUnit       (testCase)+import           Test.Framework.Providers.QuickCheck2 (testProperty)+import           Test.HUnit                           hiding (Test)+import qualified Test.QuickCheck                      as QC+import qualified Test.QuickCheck.Monadic              as QCM+------------------------------------------------------------------------------+import qualified Snap.Snaplet.Auth                    as A+import           Snap.TestCommon                      (eqTestCase, ordTestCase, readTestCase, showTestCase)+++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Auth type tests" [+    testCase     "Password serialization"          dontSerializeClearText+  , testCase     "Fill in [] roles"                deserializeDefaultRoles+  , testCase     "Fail deserialization"            failDeserialize+  , testProperty "AuthFailure show instances"      authFailureShows+  , testProperty "Encrypt agrees with password"    encryptByteString+  , testCase     "Reject clear encrypted pw check" rejectCheckClearText+  , testCase     "Test Role Show instance"         $ showTestCase (A.Role "a")+  , testCase     "Test Role Read instance"         $ readTestCase (A.Role "a")+  , testCase     "Test Role Ord  instance"         $+    ordTestCase (A.Role "a") (A.Role "b")+  , testCase     "Test PW Show instance"           $+    showTestCase (A.ClearText "pw")+  , testCase     "Test PW Read instance"           $+    readTestCase (A.ClearText "pw")+  , testCase     "Test PW Ord  instance"           $+    ordTestCase (A.ClearText "a") (A.ClearText "b")+  , testCase     "Test AuthFailure Eq instance"    $+    eqTestCase A.BackendError A.DuplicateLogin --TODO better as property+  , testCase     "Test AuthFailure Show instance"  $+    showTestCase A.BackendError+--  , testCase     "Test AuthFailure Read instance"  $+--    readTestCase BackendError -- TODO/NOTE: show . read isn't id for+  , testCase     "Test AuthFailure Ord instance"   $+    ordTestCase A.BackendError A.DuplicateLogin+  , testCase     "Test UserId Show instance"       $+    showTestCase (A.UserId "1")+  , testCase     "Test UserId Read instance"       $+    readTestCase (A.UserId "2")+  , testCase     "Test AuthUser Show instance"     $+    showTestCase A.defAuthUser+  , testCase     "Test AuthUser Eq instance"       $+    eqTestCase A.defAuthUser A.defAuthUser+  ]+++------------------------------------------------------------------------------+dontSerializeClearText :: Assertion+dontSerializeClearText = do+  let s = encode (A.ClearText "passwordisnthamster")+  -- Take the length of the ByteString to force it completely, rather than+  -- using deepseq; BSL.ByteString lacked an NFData instance until+  -- bytestring-0.10.+  r <- try $ evaluate (BSL.length s) >> return s+  case r of+    Left  e -> (e :: SomeException) `seq` return ()+    Right j -> assertFailure $+               "Failed to reject ClearText password serialization: "+               ++ show j+ +------------------------------------------------------------------------------+sampleUserJson :: T.Text -> T.Text -> T.Text+sampleUserJson reqPair optPair = T.intercalate "," [+    "{\"uid\":\"1\""+  , "\"login\":\"foo\""+  , "\"email\":\"test@example.com\""+  , "\"pw\":\"sha256|12|gz47sA0OvbVjos51OJRauQ==|Qe5aU2zAH0gIKHP68KrHJkvvwTvTAqA6UgA33BRpNEo=\""+  , reqPair+  , "\"suspended_at\":null"+  , "\"remember_token\":\"81160620ef9b64865980c2ab760fcf7f14c06e057cbe1e723cba884a9be05547\""+  , "\"login_count\":2"+  , "\"failed_login_count\":1"+  , "\"locked_until\":null"+  , "\"current_login_at\":\"2014-06-24T14:43:51.241Z\""+  , "\"last_login_at\":null"+  , "\"current_ip\":\"127.0.0.1\""+  , "\"last_ip\":null"+  , "\"created_at\":\"2014-06-24T14:43:51.236Z\""+  , "\"updated_at\":\"2014-06-24T14:43:51.242Z\""+  , "\"reset_token\":null"+  , "\"reset_requested_at\":null"+  , optPair+  , "\"meta\":{}}"+  ]+++------------------------------------------------------------------------------+deserializeDefaultRoles :: Assertion+deserializeDefaultRoles =+  either+  (\e -> assertFailure $ "Failed user deserialization: " ++ e)+  (\u -> assertEqual "Roles wasn't initialized to empty" [] (A.userRoles u))+  (eitherDecode . BSL.fromChunks . (:[]) . encodeUtf8 $+   sampleUserJson "\"activated_at\":null" "\"extra\":null")+++------------------------------------------------------------------------------+failDeserialize :: Assertion+failDeserialize = do+  case decode . BSL.fromChunks . (:[]) . encodeUtf8 $ t of+    Nothing -> return ()+    Just a  -> assertFailure $+               "Expected deserialization failure, got authUser: "+               ++ show (a :: A.AuthUser)++  where+    t = T.replace "login" "loogin" $+        sampleUserJson "\"extra\":null" "\"extra2\":null"+++------------------------------------------------------------------------------+authFailureShows :: A.AuthFailure -> Bool+authFailureShows ae = length (show ae) > 0+++------------------------------------------------------------------------------+instance QC.Arbitrary A.AuthFailure where+  arbitrary = do+    s <- (QC.arbitrary `QC.suchThat` (( > 0 ) . length))+    tA <- QC.arbitrary+    tB <- QC.arbitrary+    let t = UTCTime+            (ModifiedJulianDay tA)+            (realToFrac (tB :: Double))+    QC.oneof $ map return [A.AuthError s,       A.BackendError+                          ,A.DuplicateLogin,    A.EncryptedPassword+                          ,A.IncorrectPassword, A.LockedOut t+                          ,A.PasswordMissing,   A.UsernameMissing+                          ,A.UserNotFound+                          ]+++------------------------------------------------------------------------------+encryptByteString :: QC.Property+encryptByteString = QCM.monadicIO testStringEq+  where+    clearPw = BS.pack `liftM` (QC.arbitrary `QC.suchThat` ((>0) . length))+    testStringEq = QCM.forAllM clearPw $ \s -> do+      ePW  <- A.Encrypted `liftM` (QCM.run $ A.encrypt s)++      let cPW  = A.ClearText s+{-      ePW' <- QCM.run $ encryptPassword (ClearText s)+      QCM.assert $ (checkPassword cPW ePW+                    && checkPassword cPW cPW+                    && checkPassword ePW ePW') --TODO/NOTe: This fails.+                                                 Surpsising?+                                                 Encrypt twice and get two+                                                 different password hashes -}+      QCM.assert $ (A.checkPassword cPW ePW+                    && A.checkPassword cPW (A.ClearText s))+++------------------------------------------------------------------------------+rejectCheckClearText :: Assertion+rejectCheckClearText = do+  let b = A.checkPassword (A.Encrypted "") (A.ClearText "")+  r <- try $ b `seq` return b+  case r of+    Left  e -> (e :: SomeException) `seq` return ()+    Right _ -> assertFailure+               "checkPassword should not accept encripted-clear pair"+
+ test/suite/Snap/Snaplet/Config/Tests.hs view
@@ -0,0 +1,102 @@+module Snap.Snaplet.Config.Tests where++------------------------------------------------------------------------------+import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad+import qualified Data.ByteString.Char8 as BS+import qualified Data.Configurator.Types as C+import Data.Function+import qualified Data.Map as Map+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+import Data.Monoid hiding ((<>))+#else+import Data.Monoid+#endif+import Data.Typeable+import System.Environment+------------------------------------------------------------------------------+import Snap.Core+import Snap.Http.Server.Config+import Snap.Snaplet+import Snap.Snaplet.Config+import Snap.Snaplet.Heist+import Snap.Snaplet.Test.Common.App+import Snap.Snaplet.Internal.Initializer+import qualified Snap.Test as ST+import Snap.Snaplet.Test+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.HUnit hiding (Test)+++------------------------------------------------------------------------------+configTests :: Test+configTests = testGroup "Snaplet Config"+        [ testProperty "Monoid left identity"     monoidLeftIdentity+        , testProperty "Monoid right identity"    monoidRightIdentity+        , testProperty "Monoid associativity"     monoidAssociativity+        , testCase     "Verify Typeable instance" verTypeable+--        , testCase     "Config options used"      appConfigGetsToConfig+        ]++newtype ArbAppConfig = ArbAppConfig { unArbAppConfig :: AppConfig }++instance Show ArbAppConfig where+  show (ArbAppConfig (AppConfig a)) =+    "ArbAppConfig (AppConfig " ++ show a ++ ")"++instance Eq ArbAppConfig where+  a == b = ((==) `on` (appEnvironment . unArbAppConfig)) a b++instance Arbitrary ArbAppConfig where+  arbitrary = liftM (ArbAppConfig . AppConfig) arbitrary++instance Semigroup ArbAppConfig where+  a <> b = ArbAppConfig $ ((<>) `on` unArbAppConfig) a b++instance Monoid ArbAppConfig where+  mempty        = ArbAppConfig mempty+#if !MIN_VERSION_base(4,11,0)+  mappend = (<>)+#endif++monoidLeftIdentity :: ArbAppConfig -> Bool+monoidLeftIdentity a = mempty <> a == a++monoidRightIdentity :: ArbAppConfig -> Bool+monoidRightIdentity a = a <> mempty == a++monoidAssociativity :: ArbAppConfig -> ArbAppConfig -> ArbAppConfig+                    -> Bool+monoidAssociativity a b c = (a <> b) <> c == a <> (b <> c)+++------------------------------------------------------------------------------+verTypeable :: Assertion+verTypeable =+  assertEqual "Unexpected Typeable behavior"+#if MIN_VERSION_base(4,7,0)+    "AppConfig"+#else+    "Snap.Snaplet.Config.AppConfig"+#endif+  (show . typeOf $ (undefined :: AppConfig))+++------------------------------------------------------------------------------+appConfigGetsToConfig :: Assertion+appConfigGetsToConfig = do+  opts <- completeConfig =<<+          commandLineAppConfig defaultConfig  :: IO (Config Snap AppConfig)+  a    <- async . withArgs ["-p", "8001","-e","otherEnv"] $+          serveSnaplet opts appInit+  threadDelay 500000+  cancel a+  b    <- async . withArgs ["--environment","devel"] $ serveSnaplet defaultConfig appInit+  threadDelay 500000+  cancel b+  --TODO - Don't just run the server to touch the config code. Check some values
+ test/suite/Snap/Snaplet/Heist/Tests.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.Heist.Tests where+++------------------------------------------------------------------------------+import           Control.Applicative+import           Control.Monad                  (join)+import           Control.Monad.IO.Class         (liftIO)+import qualified Data.ByteString.Char8          as BSC+import           Data.List                      (isInfixOf)+import qualified Data.Set                       as Set+import qualified Data.Map                       as Map+import qualified Data.Text                      as T+import           Test.HUnit                     (Assertion, assertBool,+                                                 assertFailure)+import qualified Test.Framework                 as F+import           Test.Framework.Providers.HUnit (testCase)+------------------------------------------------------------------------------+import           Data.Map.Syntax                ((##))+import qualified Heist                          as H+import qualified Heist.Interpreted              as I+import           Snap.Snaplet                   (with)+import qualified Snap.Test                      as ST+import           Snap.TestCommon                (expectException)+import           Snap.Snaplet.Test              (evalHandler, runHandler)+import qualified Snap.Snaplet.Heist             as HS+import qualified Snap.Snaplet.Heist.Compiled    as C+import qualified Snap.Snaplet.Heist.Interpreted as I+import           Snap.Snaplet.Test.Common.App   (appInit, appInit', heist)+import qualified Text.XmlHtml                   as XML++heistTests :: F.Test+heistTests = F.testGroup "Snap.Snaplet.Heist"+             [testCase "Load templates" addTemplatesOK+             ,testCase "Get Heist state" assertHasTemplates+             ,testCase "Handler with heist state" accessibleHeistState+             ,testCase "gRender a template" gSimpleRender+--             ,testCase "gRender another template" gSimpleRenderAnother -- TODO investigate+             ,testCase "cRender a template" (simpleRender False)+             ,testCase "Render a template"  (simpleRender True)+             ,testCase "gRenderAs a small template" gSimpleRenderAs+             ,testCase "cRenderAs a template" (simpleRenderAs False)+             ,testCase "renderAs a template"  (simpleRenderAs True)+             ,testCase "gServe existing template" gSimpleHeistServeOK+             ,testCase "cServe templates" (simpleHeistServeOK False)+             ,testCase "serve templates" (simpleHeistServeOK True)+             ,testCase "gHeistServe underscore template" gSimpleHeistServeUnd+             ,testCase "gHeistServe missing template" gSimpleHeistServeMissing+             ,testCase "gHeistServeSingle template" gSimpleHeistServeSingle+             ,testCase "cHeistServeSingle template"+              (simpleHeistServeSingle False)+             ,testCase "heistServeSingle template"+              (simpleHeistServeSingle True)+             ,testCase "gHeistServeSingle underscored template"+              gSimpleHeistServeSingleUnd+             ,testCase "gHeistServeSingle missing template"+              gSimpleHeistServeSingleMissing+             ,testCase "Choose compiled mode" chooseCompiled+             ,testCase "Choose interpreted mode" chooseInterpreted+             ,testCase "Render with splices" fooRenderWith+             ,testCase "Recognize withSplices" seeLocalSplices+             ,testCase "Recognize heistLocal" seeLocalState+             ,testCase "cRender with compiled module" compiledModuleRender+             ,testCase "cRenderAs compiled module" compiledModuleRenderAs+             ,testCase "cHeistServe a template" compiledModuleServe+             ,testCase "cHeistServeSingle a template" compiledModuleServeOne+             ]+++------------------------------------------------------------------------------+addTemplatesOK :: Assertion+addTemplatesOK = do+  let hdl = with heist $ I.render "foopage"+  res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+  either (assertFailure . show) (ST.assertSuccess) res+++------------------------------------------------------------------------------+assertHasTemplates :: Assertion+assertHasTemplates = do+  let hdl = with heist $  do+        s  <- HS.getHeistState+        t  <- return $ H.templateNames s+        sp <- return $ H.spliceNames s+        sc <- return $ H.compiledSpliceNames s+        liftIO $ putStrLn $ "Templates " ++ unwords (map show t)+        liftIO $ putStrLn $ "Splices: " ++ unwords (map show sp)+        liftIO $ putStrLn $ "Compiled splices: " ++ unwords (map show sc)+        return $ Set.fromList (map head t)+  res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+  assertBool "templateNames include foopage, barpage, bazpage" $ +    (Right (Set.fromList [])) ==+    (Set.difference+     (Set.fromList ["foopage","barpage","bazpage"])+     <$> res)+++------------------------------------------------------------------------------+accessibleHeistState :: Assertion+accessibleHeistState = do+  let hdl = with heist . HS.withHeistState $+        I.lookupSplice "thisSpliceDoesntExist"+  res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+  either (assertFailure . show) (ST.assertSuccess) res+++------------------------------------------------------------------------------+gSimpleRender :: Assertion+gSimpleRender = do+  let hdl = with heist $ HS.gRender "foopage"+  res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+  either (assertFailure . show) ST.assertSuccess res++gSimpleRenderAnother :: Assertion+gSimpleRenderAnother = do+  let hdl = with heist $ HS.gRender "bazpage"+  res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+  either (assertFailure . show) ST.assertSuccess res++------------------------------------------------------------------------------+simpleRender :: Bool -> Assertion+simpleRender interp = do+  let hdl = with heist $+            HS.chooseMode (HS.cRender "foopage") (HS.render "foopage")+  res <- runHandler Nothing (ST.get "" Map.empty) hdl+         (appInit' interp False)+  either (assertFailure . show) ST.assertSuccess res+++------------------------------------------------------------------------------+gSimpleRenderAs :: Assertion+gSimpleRenderAs = do+  let hdl = with heist $ HS.gRenderAs "audio/ogg" "foopage"+      defReq = ST.get "" Map.empty+      rs = either (return . T.unpack)+           (\r -> (BSC.unpack <$> ST.responseToString r))+  resStr <- join $ rs <$> runHandler Nothing defReq hdl appInit+  assertBool "gRenderAs should set content to audio/ogg" $+    ("audio/ogg" `isInfixOf` resStr)+++------------------------------------------------------------------------------+simpleRenderAs :: Bool -> Assertion+simpleRenderAs interp = do+  let hdl = with heist $ HS.chooseMode+            (HS.cRenderAs "audio/ogg" "foopage")+            (HS.renderAs  "audio/ogg" "foopage")+      defReq = ST.get "" Map.empty+      rs  = either (return . T.unpack)+            (\r -> (BSC.unpack <$> ST.responseToString r))++  resStr <- join $ rs <$> runHandler Nothing defReq hdl+                          (appInit' interp False)+  assertBool "renderAs should set content to audio/ogg" $+        ("audio/ogg" `isInfixOf` resStr)+++------------------------------------------------------------------------------+gSimpleHeistServeOK :: Assertion+gSimpleHeistServeOK = do+  let hdl = with heist HS.gHeistServe+  res <- runHandler Nothing (ST.get "index" Map.empty) hdl appInit+  either (assertFailure . show) ST.assertSuccess res+++------------------------------------------------------------------------------+simpleHeistServeOK :: Bool -> Assertion+simpleHeistServeOK interp = do+  let hdl = with heist $ HS.chooseMode HS.cHeistServe HS.heistServe+  res <- runHandler Nothing (ST.get "foopage" Map.empty) hdl+         (appInit' interp False)+  either (assertFailure . show) ST.assertSuccess res++------------------------------------------------------------------------------+gSimpleHeistServeUnd :: Assertion+gSimpleHeistServeUnd = do+  let hdl = with heist HS.gHeistServe+  res <- runHandler Nothing (ST.get "_foopage" Map.empty) hdl appInit+  either (assertFailure . show) ST.assert404 res+++------------------------------------------------------------------------------+gSimpleHeistServeMissing :: Assertion+gSimpleHeistServeMissing = do+  let hdl = with heist HS.gHeistServe+  res <- runHandler Nothing (ST.get "nonexisting" Map.empty) hdl appInit+  either (assertFailure . show) ST.assert404 res+++simpleHeistServeSingle :: Bool -> Assertion+simpleHeistServeSingle interp = do+  let hdl = with heist $ HS.chooseMode+            (HS.cHeistServeSingle "foopage")+            (HS.heistServeSingle  "foopage")+  res <- runHandler Nothing (ST.get "foopage" Map.empty) hdl+         (appInit' interp False)+  either (assertFailure . show) ST.assertSuccess res++------------------------------------------------------------------------------+-- Serves foopage, despite request for nonexistent+gSimpleHeistServeSingle :: Assertion+gSimpleHeistServeSingle = do+  let hdl = with heist $ HS.gHeistServeSingle "foopage"+  res <- runHandler Nothing (ST.get "nonexistent" Map.empty) hdl appInit+  either (assertFailure . show) ST.assertSuccess res+++------------------------------------------------------------------------------+-- serveSingle does not filter out underscored templates+gSimpleHeistServeSingleUnd :: Assertion+gSimpleHeistServeSingleUnd = do+  let hdl = with heist $ I.heistServeSingle "_foopage"+  res <- runHandler Nothing (ST.get "_foopage" Map.empty) hdl appInit+  either (assertFailure . show) ST.assertSuccess res++------------------------------------------------------------------------------+gSimpleHeistServeSingleMissing :: Assertion+gSimpleHeistServeSingleMissing = do+  let hdl = with heist $ HS.gHeistServeSingle "nonexistent"+  expectException+    "gHeistServeSingle failed to throw when serving nonexistent template"+    (runHandler Nothing (ST.get "nonexistent" Map.empty) hdl appInit)+    ++------------------------------------------------------------------------------+chooseCompiled :: Assertion+chooseCompiled = do+  let hdl = with heist $ HS.chooseMode+            (liftIO $ return ())+            (liftIO $ assertFailure "Should have chosen compiled mode")+  res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+  either (assertFailure . show) return res+++------------------------------------------------------------------------------+chooseInterpreted :: Assertion+chooseInterpreted = do+  let hdl = with heist $ HS.chooseMode+            (liftIO $ assertFailure "Should have chosen intpreted mode")+            (liftIO $ return ())+  res <- evalHandler Nothing (ST.get "" Map.empty) hdl+         (appInit' True False)+  either (assertFailure . show) return res+++------------------------------------------------------------------------------+fooRenderWith :: Assertion+fooRenderWith = do+  let mySplices = ("aSplice" ## I.textSplice "Content")+      hdl = with heist $ HS.renderWithSplices "foopage" mySplices+  res  <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+  rStr <- either (const $ return "") ST.responseToString res+  assertBool "Splice was not spliced in" (BSC.isInfixOf "Content" (rStr :: BSC.ByteString))+++------------------------------------------------------------------------------+seeLocalSplices :: Assertion+seeLocalSplices = do+  let mySplices = do+        "aSplice" ## I.textSplice "Content"+        "bSplice" ## I.textSplice "BContent"+      hdl = with heist $+            HS.withSplices mySplices (HS.withHeistState H.spliceNames)+  res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+  either+    (assertFailure . show)+    (\r -> assertBool "Local splices not stored" $+           all (`elem` r) ["aSplice","bSplice"])+    res+  ++------------------------------------------------------------------------------+seeLocalState :: Assertion+seeLocalState = do+  let hdl = with heist $ +            HS.heistLocal+            (I.addTemplate "tinyTemplate" [XML.TextNode "aNode"] Nothing)+            (HS.withHeistState H.templateNames)+  res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+  either (assertFailure . show)+    (\r -> assertBool "Local state template not found" $+           "tinyTemplate" `elem` (map head r)) res+++------------------------------------------------------------------------------+compiledModuleRender :: Assertion+compiledModuleRender = do+  let hdl = with heist $ C.render "foopage"+  res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+  either (assertFailure . show) ST.assertSuccess res+++------------------------------------------------------------------------------+compiledModuleRenderAs :: Assertion+compiledModuleRenderAs = do+  let hdl = with heist $ C.renderAs "audio/ogg" "foopage"+  res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+  rStr <- either (\_ -> return "") (ST.responseToString) res+  assertBool "Compiled Heist snaplet response should contain \"audoi/ogg\""+    (BSC.isInfixOf "audio/ogg" rStr)+++------------------------------------------------------------------------------+compiledModuleServe :: Assertion+compiledModuleServe = do+  let hdl = with heist $ C.heistServe+  res <- runHandler Nothing (ST.get "foopage" Map.empty) hdl appInit+  either (assertFailure . show) ST.assertSuccess res+++------------------------------------------------------------------------------+compiledModuleServeOne :: Assertion+compiledModuleServeOne = do+  let hdl = with heist $ C.heistServeSingle "foopage"+  res <- runHandler Nothing (ST.get "foopage" Map.empty) hdl appInit+  either (assertFailure . show) ST.assertSuccess res
+ test/suite/Snap/Snaplet/Internal/LensT/Tests.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TemplateHaskell #-}++module Snap.Snaplet.Internal.LensT.Tests (tests) where++import           Control.Lens+import           Control.Applicative+import           Control.Category+import           Control.Monad.Identity+import           Control.Monad.State.Strict+import           Prelude hiding (catch, (.))+import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.HUnit hiding (Test, path)+++------------------------------------------------------------------------------+import           Snap.Snaplet.Internal.LensT+++------------------------------------------------------------------------------+data TestType = TestType {+      _int0 :: Int+    , _sub  :: TestSubType+} deriving (Show)++data TestSubType = TestSubType {+      _sub0 :: Int+    , _sub1 :: Int+    , _bot  :: TestBotType+} deriving (Show)++data TestBotType = TestBotType {+      _bot0 :: Int+} deriving (Show)++makeLenses ''TestType+makeLenses ''TestSubType+makeLenses ''TestBotType+++------------------------------------------------------------------------------+defaultState :: TestType+defaultState = TestType 1 $ TestSubType 2 999 $ TestBotType 3+++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Snap.Snaplet.Internal.LensT"+                  [ testfmap+                  , testApplicative+                  , testMonadState+                  ]+++------------------------------------------------------------------------------+testfmap :: Test+testfmap = testCase "lensed/fmap" $ do+--    x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState+    let x = fst $ runIdentity (runLensT (fmap (*2) three) (sub . bot) defaultState)+    assertEqual "fmap" 6 x++    let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState)++    assertEqual "fmap2" (12 :: Int) y+    assertEqual "lens" (13 :: Int) $ _bot0 $ _bot $ _sub s'+    return ()++  where+--    three :: LensT TestType TestBotType IO Int+    three = return 3++    twiddle = do+        modify $ \(TestBotType x) -> TestBotType (x+10)+        fmap (+9) three+++------------------------------------------------------------------------------+testApplicative :: Test+testApplicative = testCase "lensed/applicative" $ do+--    x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState+    let x = fst $ runIdentity (runLensT (pure (*2) <*> three) (sub . bot) defaultState)+    assertEqual "fmap" 6 x++    let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState)++    assertEqual "fmap2" (12::Int) y+    assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'+    return ()++  where+--    three :: LensT TestType TestBotType IO Int+    three = pure 3++    twiddle = do+        modify $ \(TestBotType x) -> TestBotType (x+10)+        pure [] *> (pure (+9) <*> three) <* pure []+++------------------------------------------------------------------------------+testMonadState :: Test+testMonadState = testCase "lens/MonadState" $ do+--    s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState+    let s = snd $ runIdentity (runLensT go (sub . bot . bot0) defaultState)++    assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s+    assertEqual "sub0" 3 $ _sub0 $ _sub s+    assertEqual "sub1" 999 $ _sub1 $ _sub s++  where+--    go :: LensT TestType Int IO ()+    go = do+        modify (*2)+        modify (+3)+        withTop sub go'++--    go' :: LensT TestType TestSubType IO ()+    go' = do+        a <- with sub0 get+        with sub0 $ put $ a+1++
+ test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE TemplateHaskell #-}++module Snap.Snaplet.Internal.Lensed.Tests (tests) where++import           Control.Applicative+import           Control.Category+import           Control.Exception+import           Control.Lens+import           Control.Monad.State.Lazy+import           Prelude hiding (catch, (.))+import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.HUnit hiding (Test, path)+++------------------------------------------------------------------------------+import           Snap.Snaplet.Internal.Lensed+++------------------------------------------------------------------------------+data TestType = TestType {+      _int0 :: Int+    , _sub  :: TestSubType+} deriving (Show)++data TestSubType = TestSubType {+      _sub0 :: Int+    , _sub1 :: Int+    , _bot  :: TestBotType+} deriving (Show)++data TestBotType = TestBotType {+      _bot0 :: Int+} deriving (Show)++makeLenses ''TestType+makeLenses ''TestSubType+makeLenses ''TestBotType+++------------------------------------------------------------------------------+defaultState :: TestType+defaultState = TestType 1 $ TestSubType 2 999 $ TestBotType 3+++------------------------------------------------------------------------------+tests = testGroup "Snap.Snaplet.Internal.Lensed"+                  [ testfmap+                  , testApplicative+                  , testMonadState+                  ]+++------------------------------------------------------------------------------+testfmap :: Test+testfmap = testCase "lensed/fmap" $ do+    x <- evalStateT (lensedAsState (fmap (*2) three) (sub . bot)) defaultState+    assertEqual "fmap" 6 x++    (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState++    assertEqual "fmap2" 12 y+    assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'+    return ()++  where+    three :: Lensed TestType TestBotType IO Int+    three = return 3++    twiddle = do+        modify $ \(TestBotType x) -> TestBotType (x+10)+        fmap (+9) three+++------------------------------------------------------------------------------+testApplicative :: Test+testApplicative = testCase "lensed/applicative" $ do+    x <- evalStateT (lensedAsState (pure (*2) <*> three) (sub . bot)) defaultState+    assertEqual "fmap" 6 x++    (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState++    assertEqual "fmap2" (12::Int) y+    assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'+    return ()++  where+    three :: Lensed TestType TestBotType IO Int+    three = pure 3++    twiddle = do+        modify $ \(TestBotType x) -> TestBotType (x+10)+        pure [] *> (pure (+9) <*> three) <* pure []+++------------------------------------------------------------------------------+testMonadState :: Test+testMonadState = testCase "lens/MonadState" $ do+    s <- execStateT (lensedAsState go (sub . bot . bot0)) defaultState++    assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s+    assertEqual "sub0" 3 $ _sub0 $ _sub s+    assertEqual "sub1" 1000 $ _sub1 $ _sub s++  where+    go :: Lensed TestType Int IO ()+    go = do+        modify (*2)+        modify (+3)+        withTop sub go'++    go' :: Lensed TestType TestSubType IO ()+    go' = do+        a <- with sub0 get+        with sub0 $ put $ a+1+        embed sub1 go''++    go'' :: Lensed TestSubType Int IO ()+    go'' = modify (+1)+++eat :: SomeException -> IO ()+eat _ = return ()++qqq = defaultMainWithArgs [tests] ["--plain"] `catch` eat
+ test/suite/Snap/Snaplet/Internal/RST/Tests.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TemplateHaskell #-}++module Snap.Snaplet.Internal.RST.Tests+  ( tests ) where++import           Control.Applicative+import           Control.Monad.Identity+import           Control.Monad.Reader+import           Control.Monad.State+import           Prelude hiding (catch, (.))+import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.Framework.Providers.QuickCheck2+import           Test.HUnit hiding (Test, path)++import           Snap.Snaplet.Internal.RST+++tests :: Test+tests = testGroup "Snap.Snaplet.Internal.RST"+    [ testExec+    , testEval+    , testFail+    , testAlternative+    ]+++testEval :: Test+testEval = testProperty "RST/execRST" prop+  where+    prop x = runIdentity (evalRST m x undefined) == x+    m :: RST Int () Identity Int+    m = ask++testExec :: Test+testExec = testProperty "RST/execRST" prop+  where+    prop x = runIdentity (execRST m undefined x) == x+    m :: RST () Int Identity Int+    m = get++testFail :: Test+testFail = testCase "RST/fail" $+    assertEqual "RST fail" rstFail Nothing++testAlternative :: Test+testAlternative = testCase "RST/Alternative" $ do+    assertEqual "Alternative instance" rstAlt (Just (5, 1))+    assertEqual "Alternative instance" rstAlt2 (Just (5, 1))++addEnv :: Monad m => RST Int Int m ()+addEnv = do+    v <- ask+    modify (+v)++rstAlt :: Maybe (Int, Int)+rstAlt = runRST (addEnv >> (empty <|> (return 5))) 1 0++rstAlt2 :: Maybe (Int, Int)+rstAlt2 = runRST (addEnv >> ((return 5) <|> empty)) 1 0++rstFail :: Maybe Int+rstFail = evalRST (fail "foo") (0 :: Int) (0 :: Int)+
+ test/suite/Snap/Snaplet/Internal/Tests.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports      #-}+{-# LANGUAGE TemplateHaskell     #-}++module Snap.Snaplet.Internal.Tests+  ( tests, initTest ) where++------------------------------------------------------------------------------+import           Control.Lens                        (makeLenses)+import           Control.Monad.Trans                 (MonadIO, liftIO)+import           Data.ByteString                     (ByteString)+import qualified Data.ByteString.Char8               as B+import           Data.Text                           (Text)+import           Prelude                             hiding (catch, (.))+import           System.Directory                    (getCurrentDirectory)+import           Test.Framework                      (Test, testGroup)+import           Test.Framework.Providers.HUnit      (testCase)+import           Test.Framework.Providers.SmallCheck (testProperty)+import           Test.HUnit                          hiding (Test, path)+import           Test.SmallCheck                     ((==>))+------------------------------------------------------------------------------+import           Snap.Snaplet.Internal.Initializer+import           Snap.Snaplet.Internal.Types+++                       ---------------------------------+                       -- TODO: this module is a mess --+                       ---------------------------------+++------------------------------------------------------------------------------+data Foo = Foo Int++data Bar = Bar Int+++data App = App+    { _foo :: Snaplet Foo+    , _bar :: Snaplet Bar+    }++makeLenses ''App++--showConfig :: SnapletConfig -> IO ()+--showConfig c = do+--    putStrLn "SnapletConfig:"+--    print $ _scAncestry c+--    print $ _scFilePath c+--    print $ _scId c+--    print $ _scDescription c+--    print $ _scRouteContext c+--    putStrLn ""+++------------------------------------------------------------------------------+assertGet :: (MonadIO m, Show a, Eq a) => String -> m a -> a -> m ()+assertGet name getter val = do+    v <- getter+    liftIO $ assertEqual name val v+++------------------------------------------------------------------------------+configAssertions :: (MonadSnaplet m, MonadIO (m b v))+                 => [Char]+                 -> ([Text], FilePath, Maybe Text, Text, ByteString)+                 -> m b v ()+configAssertions prefix (a,f,n,d,r) = do+    assertGet (prefix ++ "ancestry"      ) getSnapletAncestry    a+    assertGet (prefix ++ "file path"     ) getSnapletFilePath    f+    assertGet (prefix ++ "name"          ) getSnapletName        n+    assertGet (prefix ++ "description"   ) getSnapletDescription d+    assertGet (prefix ++ "route context" ) getSnapletRootURL     r+++------------------------------------------------------------------------------+appInit :: SnapletInit App App+appInit = makeSnaplet "app" "Test application" Nothing $ do+    cwd <- liftIO getCurrentDirectory++    configAssertions "root "+        ([], cwd, Just "app", "Test application", "")++    assertGet "environment" getEnvironment "devel"++    f <- nestSnaplet "foo" foo $ fooInit+    b <- nestSnaplet "bar" bar $ barInit+    return $ App f b+++------------------------------------------------------------------------------+fooInit :: SnapletInit b Foo+fooInit = makeSnaplet "foo" "Foo Snaplet" Nothing $ do+    cwd <- liftIO getCurrentDirectory+    let dir = cwd ++ "/snaplets/foo"++    configAssertions "foo "+        (["app"], dir, Just "foo", "Foo Snaplet", "foo")+    return $ Foo 42+++------------------------------------------------------------------------------+barInit :: SnapletInit b Bar+barInit = makeSnaplet "bar" "Bar Snaplet" Nothing $ do+    cwd <- liftIO getCurrentDirectory+    let dir = cwd ++ "/snaplets/bar"+    configAssertions "bar "+        (["app"], dir, Just "bar", "Bar Snaplet", "bar")+    return $ Bar 2+++------------------------------------------------------------------------------+initTest :: IO ()+initTest = do+    (out,_,_) <- runSnaplet Nothing appInit++    -- note from gdc: wtf?+    if out == "aoeu"+      then putStrLn "Something really strange"+      else return ()+++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Snap.Snaplet.Internal"+    [ testCase "initializer tests" initTest+    , testProperty "buildPath generates no double slashes" doubleSlashes+    ]++--doubleSlashes :: Monad m => [String] -> Property m+doubleSlashes arrStr = noSlashes ==> not (B.isInfixOf "//" $ buildPath arr)+  where+    arr = map B.pack arrStr+    noSlashes = not $ or $ map (B.elem '/') arr++
+ test/suite/Snap/Snaplet/Test/Common/App.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeSynonymInstances  #-}++module Snap.Snaplet.Test.Common.App (+  App,+  appInit,+  appInit',+  auth,+  failingAppInit,+  heist,+  session,+  embedded,+  foo,+  bar+  )where++------------------------------------------------------------------------------+import           Control.Lens                                (over)+import           Control.Monad                               (when)+import           Control.Monad.Trans                         (lift)+import           Data.Monoid                                 (mempty)+------------------------------------------------------------------------------+import           Control.Applicative                         ((<|>))+import           Data.Map.Syntax                             (( #! ), ( ## ))+import           Heist                                       (Splices, Template)+import           Heist.Compiled                              (Splice, runChildren, withSplices)+import           Heist.Internal.Types                        (HeistConfig (..), SpliceConfig (..))+import           Heist.Interpreted                           (addTemplate, textSplice)+import           Snap.Core                                   (pass, writeText)+import           Snap.Snaplet                                (Handler, SnapletInit, addRoutes, embedSnaplet, getLens, getSnapletFilePath, makeSnaplet, nameSnaplet, nestSnaplet, snapletValue, with, wrapSite)+import           Snap.Snaplet.Auth                           (AuthManager, AuthSettings, addAuthSplices, authSettingsFromConfig, currentUser, defAuthSettings, userCSplices)+import           Snap.Snaplet.Auth.Backends.JsonFile         (initJsonFileAuthManager)+import           Snap.Snaplet.Heist                          (addConfig, addTemplates, heistInit', heistServe, modifyHeistState)+import           Snap.Snaplet.HeistNoClass                   (setInterpreted)+import           Snap.Snaplet.Session.Backends.CookieSession (initCookieSessionManager)+import           Snap.Snaplet.Test.Common.BarSnaplet+import           Snap.Snaplet.Test.Common.EmbeddedSnaplet+import           Snap.Snaplet.Test.Common.FooSnaplet+import           Snap.Snaplet.Test.Common.Handlers+import           Snap.Snaplet.Test.Common.Types+import           Snap.TestCommon                             (shConfigSplice)+import           Snap.Util.FileServe                         (serveDirectory)+import           Text.XmlHtml                                (Node (TextNode))++------------------------------------------------------------------------------+appInit :: SnapletInit App App+appInit = appInit' False False+++------------------------------------------------------------------------------+appInit' :: Bool -> Bool -> SnapletInit App App+appInit' hInterp authConfigFile =+  makeSnaplet "app" "Test application" Nothing $ do++  ------------------------------+  -- Initial subSnaplet setup --+  ------------------------------++  hs <- nestSnaplet "heist"   heist   $+        heistInit'+        "templates"+        (HeistConfig (mempty {_scCompiledSplices = compiledSplices}) "" True)++  sm <- nestSnaplet "session" session $+        initCookieSessionManager "sitekey.txt" "_session" Nothing (Just (30 * 60))+  fs <- nestSnaplet "foo"     foo     $ fooInit hs+  bs <- nestSnaplet ""        bar     $ nameSnaplet "baz" $ barInit hs foo+  ns <- embedSnaplet "embed" embedded embeddedInit++  --------------------------------+  -- Exercise the Heist snaplet --+  --------------------------------++  addTemplates hs "extraTemplates"++  when hInterp $ do+    modifyHeistState (addTemplate "smallTemplate" aTestTemplate Nothing)+    setInterpreted hs++  _lens <- getLens+  addConfig hs $+    mempty { _scInterpretedSplices = do+                "appsplice" ## textSplice "contents of the app splice"+                "appconfig" ## shConfigSplice _lens+           }++  ---------------------------+  -- Exercise Auth snaplet --+  ---------------------------++  authSettings <- if authConfigFile+                    then authSettingsFromConfig+                    else return defAuthSettings++  au <- nestSnaplet "auth" auth $ authInit authSettings++  addAuthSplices hs auth -- TODO/NOTE: probably not necessary (?)+++  addRoutes [ ("/hello",           writeText "hello world")+            , ("/routeWithSplice", routeWithSplice)+            , ("/routeWithConfig", routeWithConfig)+            , ("/public",          serveDirectory "public")+            , ("/sessionDemo",     sessionDemo)+            , ("/sessionTest",     sessionTest)+            ]++  wrapSite (<|> heistServe)+  return $ App hs (over snapletValue fooMod fs) au bs sm ns+++------------------------------------------------------------------------------+-- Alternative authInit for tunable settings+authInit :: AuthSettings -> SnapletInit App (AuthManager App)+authInit settings = initJsonFileAuthManager settings session "users.json"+++------------------------------------------------------------------------------+compiledSplices :: Splices (Splice (Handler App App))+compiledSplices = do+  "userSplice" #! withSplices runChildren userCSplices $+    lift $ maybe pass return =<< with auth currentUser++------------------------------------------------------------------------------+fooMod :: FooSnaplet -> FooSnaplet+fooMod f = f { fooField = fooField f ++ "z" }+++------------------------------------------------------------------------------+aTestTemplate :: Template+aTestTemplate =  [TextNode "littleTemplateNode"]+++------------------------------------------------------------------------------+failingAppInit :: SnapletInit App App+failingAppInit = makeSnaplet "app" "Test application" Nothing $ do+   _ <- error "Error"+   return undefined
+ test/suite/Snap/Snaplet/Test/Common/BarSnaplet.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}++module Snap.Snaplet.Test.Common.BarSnaplet where++------------------------------------------------------------------------------+import           Prelude                             hiding (lookup)+import           Control.Lens+import           Control.Monad.State+import qualified Data.ByteString                     as B+import           Data.Configurator+import           Data.Maybe+------------------------------------------------------------------------------+import           Data.Map.Syntax                     ((##))+import           Heist+import           Heist.Interpreted+import           Snap.Core+import           Snap.Snaplet+import           Snap.Snaplet.Heist+import           Snap.Snaplet.Test.Common.FooSnaplet+import           Snap.TestCommon                     (handlerConfig, shConfigSplice)++------------------------------------------------------------------------------+data BarSnaplet b = BarSnaplet+    { _barField :: String+    , fooLens  :: SnapletLens b FooSnaplet+    }++makeLenses ''BarSnaplet++barsplice :: Splices (SnapletISplice b)+barsplice = "barsplice" ## textSplice "contents of the bar splice"++barInit :: HasHeist b+        => Snaplet (Heist b)+        -> SnapletLens b FooSnaplet+        -> SnapletInit b (BarSnaplet b)+barInit h l = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do+    config <- getSnapletUserConfig+    addTemplates h ""+    rootUrl <- getSnapletRootURL+    _lens <- getLens+    addRoutes [("barconfig", liftIO (lookup config "barSnapletField") >>= writeLBS . fromJust)+              ,("barrooturl", writeBS $ "url" `B.append` rootUrl)+              ,("bazpage2",   renderWithSplices "bazpage" barsplice)+              ,("bazpage3",   heistServeSingle "bazpage")+              ,("bazpage4",   renderAs "text/html" "bazpage")+              ,("bazpage5",   renderWithSplices "bazpage"+                                ("barsplice" ## shConfigSplice _lens))+              ,("bazbadpage", heistServeSingle "cpyga")+              ,("bar/handlerConfig", handlerConfig)+              ]+    return $ BarSnaplet "bar snaplet data string" l+
+ test/suite/Snap/Snaplet/Test/Common/EmbeddedSnaplet.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE TypeSynonymInstances      #-}++module Snap.Snaplet.Test.Common.EmbeddedSnaplet where++------------------------------------------------------------------------------+import           Control.Lens+import           Control.Monad.State+import qualified Data.Text             as T+import           Prelude               hiding ((.))+import           System.FilePath.Posix+------------------------------------------------------------------------------+import           Data.Map.Syntax       (( ## ))+import           Heist.Interpreted+import           Snap.Snaplet+import           Snap.Snaplet.Heist++------------------------------------------------------------------------------+-- If we universally quantify EmbeddedSnaplet to get rid of the type parameter+-- mkLabels throws an error "Can't reify a GADT data constructor"+data EmbeddedSnaplet = EmbeddedSnaplet+    { _embeddedHeist :: Snaplet (Heist EmbeddedSnaplet)+    , _embeddedVal :: Int+    }++makeLenses ''EmbeddedSnaplet++instance HasHeist EmbeddedSnaplet where+    heistLens = subSnaplet embeddedHeist++embeddedInit :: SnapletInit EmbeddedSnaplet EmbeddedSnaplet+embeddedInit = makeSnaplet "embedded" "embedded snaplet" Nothing $ do+    hs <- nestSnaplet "heist" embeddedHeist $ heistInit "templates"++    -- This is the implementation of addTemplates, but we do it here manually+    -- to test coverage for addTemplatesAt.+    snapletPath <- getSnapletFilePath+    addTemplatesAt hs "onemoredir" (snapletPath </> "extra-templates")++    embeddedLens <- getLens+    addRoutes [("aoeuhtns", withSplices+                    ("asplice" ## embeddedSplice embeddedLens)+                    (render "embeddedpage"))+              ]+    return $ EmbeddedSnaplet hs 42+++embeddedSplice :: (SnapletLens (Snaplet b) EmbeddedSnaplet)+               -> SnapletISplice b+embeddedSplice embeddedLens = do+    val <- lift $ with' embeddedLens $ gets _embeddedVal+    textSplice $ T.pack $ "splice value" ++ (show val)+
+ test/suite/Snap/Snaplet/Test/Common/FooSnaplet.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}++module Snap.Snaplet.Test.Common.FooSnaplet where++------------------------------------------------------------------------------+import           Control.Lens+import           Control.Monad.State+import           Data.Configurator+import           Data.Maybe+import           Data.Monoid+import qualified Data.Text           as T+import           Prelude             hiding (lookup)+------------------------------------------------------------------------------+import           Data.Map.Syntax     (( ## ))+import           Heist+import           Heist.Interpreted+import           Snap.Core+import           Snap.Snaplet+import           Snap.Snaplet.Heist+import           Snap.TestCommon     (handlerConfig, shConfigSplice)++------------------------------------------------------------------------------+data FooSnaplet = FooSnaplet { fooField :: String }++fooInit :: HasHeist b => Snaplet (Heist b) -> SnapletInit b FooSnaplet+fooInit h = makeSnaplet "foosnaplet" "A demonstration snaplet called foo."+    (Just $ return "foosnaplet") $ do+    config <- getSnapletUserConfig+    addTemplates h ""+    rootUrl <- getSnapletRootURL+    fp <- getSnapletFilePath+    name <- getSnapletName+    _lens <- getLens+    let splices = do+            "foosplice" ## textSplice "contents of the foo splice"+            "fooconfig" ## shConfigSplice _lens+    addConfig h $ mempty & scInterpretedSplices .~ splices+    addRoutes [("fooConfig", liftIO (lookup config "fooSnapletField") >>= writeLBS . fromJust)+              ,("fooRootUrl", writeBS rootUrl)+              ,("fooSnapletName", writeText $ fromMaybe "empty snaplet name" name)+              ,("fooFilePath", writeText $ T.pack fp)+              ,("handlerConfig", handlerConfig)+              ]+    return $ FooSnaplet "foo snaplet data string"++getFooField :: Handler b FooSnaplet String+getFooField = gets fooField+
+ test/suite/Snap/Snaplet/Test/Common/Handlers.hs view
@@ -0,0 +1,60 @@+module Snap.Snaplet.Test.Common.Handlers where++------------------------------------------------------------------------------+import Control.Monad.IO.Class                        (liftIO)+import Data.Configurator                             (lookup)+import Data.Maybe                                    (fromJust, fromMaybe)+import Data.Text                                     (append, pack)+import Data.Text.Encoding                            (decodeUtf8)+------------------------------------------------------------------------------+import Data.Map.Syntax                               ((##))+import Heist.Interpreted                             (textSplice)+import Snap.Core                                     (writeText, getParam)+import Snap.Snaplet                                  (Handler, getSnapletUserConfig, with)+import Snap.Snaplet.Test.Common.FooSnaplet+import Snap.Snaplet.Test.Common.Types+import Snap.Snaplet.HeistNoClass                     (renderWithSplices)+import Snap.Snaplet.Session                          (csrfToken, getFromSession, sessionToList, setInSession, withSession)+++-------------------------------------------------------------------------------+routeWithSplice :: Handler App App ()+routeWithSplice = do+    str <- with foo getFooField+    writeText $ pack $ "routeWithSplice: "++str+++------------------------------------------------------------------------------+routeWithConfig :: Handler App App ()+routeWithConfig = do+    cfg <- getSnapletUserConfig+    val <- liftIO $ Data.Configurator.lookup cfg "topConfigField"+    writeText $ "routeWithConfig: " `append` fromJust val+++------------------------------------------------------------------------------+sessionDemo :: Handler App App ()+sessionDemo = withSession session $ do+  with session $ do+    curVal <- getFromSession "foo"+    case curVal of+      Nothing -> setInSession "foo" "bar"+      Just _ -> return ()+  list <- with session $ (pack . show) `fmap` sessionToList+  csrf <- with session $ (pack . show) `fmap` csrfToken+  renderWithSplices heist "session" $ do+    "session" ## textSplice list+    "csrf" ## textSplice csrf+++------------------------------------------------------------------------------+sessionTest :: Handler App App ()+sessionTest = withSession session $ do+  q <- getParam "q"+  val <- case q of+    Just x -> do+      let x' = decodeUtf8 x+      with session $ setInSession "test" x'+      return x'+    Nothing -> fromMaybe "" `fmap` with session (getFromSession "test")+  writeText val
+ test/suite/Snap/Snaplet/Test/Common/Types.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TemplateHaskell #-}++module Snap.Snaplet.Test.Common.Types where++------------------------------------------------------------------------------+import Control.Lens+------------------------------------------------------------------------------+import Snap.Snaplet                             (Snaplet, subSnaplet)+import Snap.Snaplet.Auth                        (AuthManager)+import Snap.Snaplet.Test.Common.BarSnaplet+import Snap.Snaplet.Test.Common.EmbeddedSnaplet+import Snap.Snaplet.Test.Common.FooSnaplet+import Snap.Snaplet.Heist+import Snap.Snaplet.Session++------------------------------------------------------------------------------+data App = App+    { _heist    :: Snaplet (Heist App)+    , _foo      :: Snaplet FooSnaplet+    , _auth     :: Snaplet (AuthManager App)+    , _bar      :: Snaplet (BarSnaplet App)+    , _session  :: Snaplet SessionManager+    , _embedded :: Snaplet EmbeddedSnaplet+    }++$(makeLenses ''App)++instance HasHeist App where+  heistLens = subSnaplet heist
+ test/suite/Snap/Snaplet/Test/Tests.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.Test.Tests+  ( tests ) where+++------------------------------------------------------------------------------+import           Control.Concurrent             (threadDelay)+import           Control.Concurrent.Async       (race)+import qualified Data.Map                       as Map+import           Test.Framework                 (Test, testGroup)+import           Test.Framework.Providers.HUnit (testCase)+import           Test.HUnit                     hiding (Test, path)+------------------------------------------------------------------------------+import           Snap.Core                      (readRequestBody, writeLBS, writeText)+import           Snap.Snaplet.Test              (closeSnaplet, evalHandler, evalHandler', getSnaplet, runHandler, runHandler')+import           Snap.Snaplet.Test.Common.App   (appInit, failingAppInit)+import qualified Snap.Test                      as ST++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Snap.Snaplet.Test"+    [ testRunHandler+    , testRunHandler'+    , testEvalHandler+    , testEvalHandler'+    , testFailingEvalHandler+    , testFailingGetSnaplet+    , readRequestBodyHangIssue -- TODO/NOTE fix+    ]+++------------------------------------------------------------------------------+testRunHandler :: Test+testRunHandler = testCase "runHandler simple" assertRunHandler+  where+    assertRunHandler :: Assertion+    assertRunHandler =+      do let hdl = writeText "Hello!"+         res <- runHandler Nothing (ST.get "" Map.empty) hdl appInit+         either (assertFailure . show)+           (ST.assertBodyContains "Hello!") res+++------------------------------------------------------------------------------+testRunHandler' :: Test+testRunHandler' = testCase "runHandler' simple" assertRunHandler'+  where+    assertRunHandler' :: Assertion+    assertRunHandler' =+      do let hdl = writeText "Hello!"+         initS <- getSnaplet Nothing appInit+         case initS of+           Left err -> assertFailure (show err)+           Right (a,is) -> do+             res <- runHandler' a is (ST.get "" Map.empty) hdl+             closeSnaplet is+             either (assertFailure . show)+               (ST.assertBodyContains "Hello!") res+++------------------------------------------------------------------------------+testEvalHandler :: Test+testEvalHandler = testCase "evalHandler simple" assertEvalHandler+  where+    assertEvalHandler :: Assertion+    assertEvalHandler =+      do let hdl = return "1+1=2"+         res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit+         either (assertFailure . show)+           (assertEqual "" ("1+1=2"::String)) res+------------------------------------------------------------------------------+testEvalHandler' :: Test+testEvalHandler' = testCase "evalHandler' simple" assertEvalHandler'+  where+    assertEvalHandler' :: Assertion+    assertEvalHandler' =+      do let hdl = return "1+1=2"+         initS <- getSnaplet Nothing appInit+         case initS of+           Left err -> assertFailure (show err)+           Right (a,is) -> do+             res <- evalHandler' a is (ST.get "" Map.empty) hdl+             closeSnaplet is+             either (assertFailure . show)+               (assertEqual "" ("1+1=2"::String)) res++testFailingEvalHandler :: Test+testFailingEvalHandler = testCase "evalHandler failing simple" assertEvalHandler+  where+    assertEvalHandler :: Assertion+    assertEvalHandler =+      do let hdl = return ("1+1=2" :: String)+         res <- evalHandler Nothing (ST.get "" Map.empty) hdl failingAppInit+         case res of+           Left _ -> assertBool "" True+           Right _ -> assertFailure "Should have failed in initializer"+++------------------------------------------------------------------------------+testFailingGetSnaplet :: Test+testFailingGetSnaplet = testCase "getSnaplet failing" assertGetSnaplet+ where+   assertGetSnaplet :: Assertion+   assertGetSnaplet =+     do initS <- getSnaplet Nothing failingAppInit+        case initS of+          Left _ -> assertBool "" True+          Right _ -> assertFailure "Should have failed in initializer"+++------------------------------------------------------------------------------+readRequestBodyHangIssue :: Test+readRequestBodyHangIssue =+  testCase "readRequestBody doesn't hang" assertReadRqBody+  where+    assertReadRqBody =+      do let hdl = readRequestBody 5000 >>= writeLBS+         res <- race+                (threadDelay 100000000)+                (runHandler Nothing (ST.get "" Map.empty) hdl appInit)+         either (assertFailure . ("readRequestBody timeout" ++) . show)+           (either (assertFailure . show) ST.assertSuccess) res
test/suite/Snap/TestCommon.hs view
@@ -1,57 +1,82 @@ module Snap.TestCommon where -import Control.Concurrent-import Control.Exception-import Control.Monad     (when)-import System.Cmd-import System.Directory-import System.Exit-import System.FilePath-import System.Process+------------------------------------------------------------------------------+import           Control.Exception               (try, SomeException)+import           Control.Monad.Trans             (lift)+import qualified Data.Text                       as T+import qualified GHC.Read                        as R+import           Test.HUnit                      (Assertion, assertFailure, assertBool)+import qualified Text.ParserCombinators.ReadPrec as R+------------------------------------------------------------------------------+import Snap.Core+import Snap.Snaplet+import Snap.Snaplet.Heist+import Heist.Interpreted -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 = bracket initialize cleanup (const testAction)-  where-    initialize = do-        cwd <- getCurrentDirectory-        let projectPath = cwd </> projName-        flip onException (setCurrentDirectory cwd >>-                          removeDirectoryRecursive projectPath) $ do-            makeWorkDirectory projectPath-            setCurrentDirectory projectPath-            systemOrDie $ "snap init " ++ snapInitArgs-            systemOrDie $ "cabal install " ++ cabalInstallArgs-            let cmd = ("." </> "dist" </> "build" </> projName </> projName)-                      ++ " -p " ++ show httpPort-            putStrLn $ "Running \"" ++ cmd ++ "\""-            pHandle <- runCommand cmd-            waitABit-            return (cwd, projectPath, pHandle) -    cleanup (cwd, projectPath, pHandle) = do-        setCurrentDirectory cwd-        terminateProcess pHandle-        waitForProcess pHandle-        removeDirectoryRecursive projectPath+------------------------------------------------------------------------------+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 -    waitABit = threadDelay $ 2*10^(6::Int) -systemOrDie :: String -> IO ()-systemOrDie s = do-    putStrLn $ "Running \"" ++ s ++ "\""-    system s >>= check+------------------------------------------------------------------------------+showTestCase :: Show a => a -> Assertion+showTestCase a = assertBool "Show instance failed" $+                 ((showsPrec 5 a) "" == show a)+                 && (showList [a]) "" == "[" ++ show a ++ "]"+                 ++------------------------------------------------------------------------------+readTestCase :: (Eq a, Show a, Read a) => a -> Assertion+readTestCase a = assertBool "Read instance failed" $+                 ( ((readsPrec 1) (show a)) == ([(a,"")]))+                 && ((readList ("[" ++ show a ++ "]")) == [([a],"")])+                 && ((R.readPrec_to_S (R.readPrec) 5) (show a) == [(a,"")])+                 && ((R.readPrec_to_S (R.readListPrec) 5) ("[" ++ show a ++ "]")+                     == [([a],"")])++                 +------------------------------------------------------------------------------+ordTestCase :: (Eq a, Ord a) => a -> a -> Assertion+ordTestCase a b = assertBool "Ord instance failed" $+                  low <= high+                  && (if   low /= high+                      then low < high  && compare low high == LT && high > low+                      else low == high && compare low high == EQ)   where-    check ExitSuccess = return ()-    check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"+    low  = min a b+    high = max a b  -makeWorkDirectory :: FilePath -> IO ()-makeWorkDirectory p = do-    doesDirectoryExist p >>= flip when (removeDirectoryRecursive p)-    createDirectory p+------------------------------------------------------------------------------+eqTestCase :: (Eq a) => a -> a -> Assertion+eqTestCase a b = assertBool "Eq instance failed" $+                 if a == b+                 then (a /= b) == False+                 else (a /= b) == True+++------------------------------------------------------------------------------+genericConfigString :: (MonadSnaplet m, Monad (m b v)) => m b v T.Text+genericConfigString = do+    a <- getSnapletAncestry+    b <- getSnapletFilePath+    c <- getSnapletName+    d <- getSnapletDescription+    e <- getSnapletRootURL+    return $ T.pack $ show (a,b,c,d,e)+++------------------------------------------------------------------------------+handlerConfig :: Handler b v ()+handlerConfig = writeText =<< genericConfigString+++------------------------------------------------------------------------------+shConfigSplice :: SnapletLens (Snaplet b) v -> SnapletISplice b+shConfigSplice _lens = textSplice =<< lift (with' _lens genericConfigString)+
test/suite/TestSuite.hs view
@@ -1,52 +1,105 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Main where -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           Test.Framework (defaultMain, Test)-import           Test.Framework.Providers.HUnit-import           Test.HUnit hiding (Test, path)+------------------------------------------------------------------------------+import           Control.Concurrent+import           Control.Exception                  (SomeException (..), bracket, catch, finally)+import           Control.Monad                      (void)+import           System.Directory                   (getCurrentDirectory, setCurrentDirectory)+import           System.FilePath                    ((</>))+import           System.IO -import           Snap.TestCommon+------------------------------------------------------------------------------+import qualified Blackbox.Tests+import           Prelude                            (Bool (False), IO, Int, Maybe (Nothing), Monad (..), Num (..), flip, return, ($), (.), (^))+import           Snap.Http.Server                   (simpleHttpServe)+import           Snap.Http.Server.Config+import           Snap.Snaplet+import qualified Snap.Snaplet.Auth.Tests+import qualified Snap.Snaplet.Config.Tests+import qualified Snap.Snaplet.Heist.Tests+import qualified Snap.Snaplet.Internal.Lensed.Tests+import qualified Snap.Snaplet.Internal.LensT.Tests+import qualified Snap.Snaplet.Internal.RST.Tests+import qualified Snap.Snaplet.Internal.Tests+import           Snap.Snaplet.Test.Common.App+import qualified Snap.Snaplet.Test.Tests+import           Test.Framework +import           SafeCWD++------------------------------------------------------------------------------ main :: IO ()-main = defaultMain tests-  where tests = [ testBarebones-                , testDefault-                ]+main = do+    -- chdir into test/+    cwd <- getCurrentDirectory+    setCurrentDirectory (cwd </> "test") +    Blackbox.Tests.remove+                "snaplets/heist/templates/bad.tpl"+    Blackbox.Tests.remove+                "snaplets/heist/templates/good.tpl"+ {- Why were we removing this?+    Blackbox.Tests.removeDir "snaplets/foosnaplet"+ -} -testBarebones :: Test-testBarebones = testCase "snap/barebones" go-  where-    go = testGeneratedProject "barebonesTest"-                              "-b"-                              ""-                              port-                              testIt-    port = 9990-    testIt = do-        body <- HTTP.simpleHttp "http://127.0.0.1:9990"-        assertEqual "server not up" "hello world" body+--    (tid, mvar) <- inDir False "non-cabal-appdir" startServer+    (tid, mvar) <- inDir False "." startServer +    defaultMain [tests]+      `finally` do+          setCurrentDirectory cwd+          killThread tid+          putStrLn "waiting for termination mvar"+          takeMVar mvar -testDefault :: Test-testDefault = testCase "snap/default" go-  where-    go = testGeneratedProject "defaultTest"-                              ""-                              ""-                              port-                              testIt-    port = 9991-    testIt = do-        body <- liftM (S.concat . L.toChunks) $-                HTTP.simpleHttp "http://127.0.0.1:9991"-        assertBool "response contains phrase 'it works!'"-                   $ "It works!" `S.isInfixOf` body+      where tests = mutuallyExclusive $+                testGroup "snap" [ internalServerTests+                                 , Snap.Snaplet.Auth.Tests.tests+                                 , Snap.Snaplet.Test.Tests.tests+                                 , Snap.Snaplet.Heist.Tests.heistTests+                                 , Snap.Snaplet.Config.Tests.configTests+                                 , Snap.Snaplet.Internal.RST.Tests.tests+                                 , Snap.Snaplet.Internal.LensT.Tests.tests+                                 , Snap.Snaplet.Internal.Lensed.Tests.tests+                                 ]  --- TODO: test hint code here++------------------------------------------------------------------------------+internalServerTests :: Test+internalServerTests =+    mutuallyExclusive $+    testGroup "internal server tests"+        [ Blackbox.Tests.tests+        , Snap.Snaplet.Internal.Lensed.Tests.tests+        , Snap.Snaplet.Internal.LensT.Tests.tests+        , Snap.Snaplet.Internal.RST.Tests.tests+        , Snap.Snaplet.Internal.Tests.tests+        ]+++------------------------------------------------------------------------------+startServer :: IO (ThreadId, MVar ())+startServer = do+    mvar <- newEmptyMVar+    t    <- forkIOWithUnmask $ \restore ->+            serve restore mvar (setPort 9753 .+                                setBind "127.0.0.1" $ defaultConfig) appInit+    threadDelay $ 2*10^(6::Int)+    return (t, mvar)++  where+    gobble m = void m `catch` \(_::SomeException) -> return ()+    serve restore mvar config initializer =+        flip finally (putMVar mvar ()) $+        gobble $ restore $ do+            hPutStrLn stderr "initializing snaplet"+            bracket (runSnaplet Nothing initializer)+                    (\(_, _, doCleanup) -> doCleanup)+                    (\(_, handler, _  ) -> do+                         (conf, site) <- combineConfig config handler+                         hPutStrLn stderr "bringing up server"+                         simpleHttpServe conf site)