packages feed

snap 0.14.0.7 → 1.1.3.3

raw patch · 124 files changed

Files

+ .ghci view
@@ -0,0 +1,2 @@+:set -XOverloadedStrings+:set -isrc
− CHANGELOG.md 
@@ -1,13 +0,0 @@-# 0.14.0.7--Fix issue #147, problems compiling with executable profiling--# 0.14.0.5--* Eliminate unnecessary dependency on syb--# 0.14.0--* Allow lens-4.8-* Remove re-export of Control.Lens.Loupe, since it was removed upstream.-* Remove re-exports of other non-snap modules in Snap.
README.md view
@@ -1,17 +1,16 @@-Snap Framework+Snap Framework [![Hackage Status](https://img.shields.io/hackage/v/snap.svg)](https://hackage.haskell.org/package/snap) ============== -Snap is a web framework for Haskell, based on iteratee I/O (as [popularized by-Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)).  For more-information about Snap, read the `README.SNAP.md` or visit the Snap project-website at http://www.snapframework.com/.+[![GitHub CI](https://github.com/snapframework/snap/workflows/CI/badge.svg)](https://github.com/snapframework/snap/actions) +Snap is a simple and fast web development framework and server written in+Haskell. For more information about Snap, read the `README.SNAP.md` or visit+the Snap project website at http://www.snapframework.com/.+ ## Library contents  This is top-level project for the Snap Framework, which contains: -  * a command-line utility for creating initial Snap applications-   * a library allowing Snap applications to recompile actions on the     fly in development mode, with no performance loss in production     mode.@@ -19,17 +18,26 @@   * a "snaplet" API allowing web applications to be build from composable     pieces. +The command-line utility `snap` for creating initial Snap applications used to+be a part of this package. As of version 1.0, the snap command-line utility is+no longer provided by this package.  It is now provided by the package+[`snap-templates`](https://github.com/snapframework/snap-templates).+ Building snap ============= -The snap tool and library are built using-[Cabal](http://www.haskell.org/cabal/) and-[Hackage](http://hackage.haskell.org/packages/hackage.html). Just run+After you clone the repository, change to the newly created snap directory and+run +    git submodule update --init --recursive+    ./init-sandbox.sh     cabal install -from the `snap` toplevel directory.-+(You may want to look at pull.sh or pullLatestMaster.sh.)+This updates all the Snap Framework dependencies to the correct version,+creates a sandbox, and installs everything.  The snap library is built using+[Cabal](http://www.haskell.org/cabal/) and+[Hackage](http://hackage.haskell.org/packages/hackage.html).  ## Building the Haddock Documentation @@ -40,23 +48,24 @@  ## Building the testsuite -To build the test suite, `cd` into the `test/` directory and run+To build the test suite, run -    $ cabal configure+    $ cabal clean+    $ cabal configure --enable-tests --enable-library-coverage     $ cabal build+    $ cabal install --enable-tests  From here you can invoke the testsuite by running:      $ ./runTestsAndCoverage.sh  -The testsuite generates an `hpc` test coverage report in `test/dist/hpc`.+The testsuite generates an `hpc` test coverage report in `dist/hpc`.   ## Roadmap to Understanding Snaplets -1. Read Tutorial.lhs which is in `project_template/tutorial/src`.+1. Read `Tutorial.lhs` which is in the `project_template/tutorial/src` directory of the `snap-templates` package. 2. Generate and read the haddock docs. 3. The test code has the nice property that it actually functions as a pretty good example app and covers a lot of the use cases. 4. If you're interested in the implementation, read design.md.-
+ changelog.md view
@@ -0,0 +1,34 @@+## 1.1.3.3++ - Update for GHC 9.8+ - Support aeson 2.2++## 1.1.3.2++ - Update for GHC 9.0 through 9.6.2++## 1.1.3.1++ - Update for GHC 8.10++<!-- n.b. where did the rest of the change log entries go?? -->++## 1.1.1.0++### Added++ - GHC 8.4 support++## 1.1.0.0++### Added++ - Support for aeson 1.x+ - GHC 8.2 support+ - New [lookupByEmail](src/Snap/Snaplet/Auth/AuthManager.hs#L62) function in the auth snaplet++## 1.0.0.0+### Removed++ - Removed support for `iteratees` in favor of +   [io-streams](https://hackage.haskell.org/package/io-streams)
+ design.md view
@@ -0,0 +1,129 @@+# Snaplet Design++The Snaplet infrastructure was designed with three high-level design goals:++* Request local state+* Composability+* Availability++First, request local state means that snaplets should be able to define their+own state that will be available during request processing.  And that state+should be mutable with scope local to the request.++Composability means that applications and snaplets should be interchangeable,+and you should be able to build them by gluing together other snaplets.++Availability means that you should be able to access your application state+without threading it manually through parameters.++## Handler++Implementing the goal of request local state means that we need some kind of a+Handler monad that will look roughly like a state transformer built on top of+the Snap monad with the top level application data as the state.  To implement+composability we also need an additional type parameter that can be changed to+match the scope of the current snaplet.  We use the `withReader :: (r1 -> r2)+-> Reader r2 a -> Reader r1 a` pattern to manage scope changes, but in order+to make our state composably mutable, we need to enlist the help of lenses+instead of accessor functions.  This allows us to keep only the top level+state and mutate the current context using the lens.++The LensT monad is our implementation of this abstraction.  It is a+combination of ReaderT and StateT (our RST abstraction).  Since the lens is+not conceptually mutable in the same way as the actual state, it is stored in+the reader environment.  The state monad part is used for the top level state+b, giving is the following newtype.++    newtype LensT b v s m a = LensT (RST (Lens b v) s m a)++LensT comes with a (MonadReader (Lens b v)) instance for retrieving the lens+and a (MonadState v) instance that uses the lens transparently to achieve+stateful behavior with the type v.  From here the definition of Handler is+fairly natural:++    newtype Handler b v a =+        Handler (LensT (Snaplet b) (Snaplet v) (Snaplet b) Snap a)++We use `LensT (Snaplet b) (Snaplet v)` instead of `LensT b (Snaplet v)`+because it is desirable to be able to use the identity lens to construct a+`Handler b b`.  The only issue with this formulation is that the lens+manipulation functions provided by LensT are not what the end user needs.  The+end user has a lens of type `Lens b (Snaplet v)` created by the `mkLabels`+function.  But LensT's withXYZ functions need `Lens (Snaplet b) (Snaplet v)`+lenses.  These can be derived easily by composing the user-supplied lens with+the internal lens `Lens (Snaplet a) a` derived from the definition of the+Snaplet data structure.++NOTE: The above definition for Handler is no longer correct.  We switched to a+slightly more specialized monad formulation called Lensed that avoids+traversal of the whole state hierarchy when the state is manipulated.  Thanks+to Edward Kmett for pointing this out and writing the code for us.++## Initializer++The second important component of snaplets is initialization.  This involves+setting up the state used by the handlers as well as defining a snaplet's+routes and cleanup actions, reading on-disk config files, and initializing and+interacting with other snaplets.  `Initializer` still uses a LensT+implementation because it does not fit the more specialized case for which+Lensed is optimized.  But it is similar enough that we can still refer to+snaplets using the same lenses that we use in Handlers.  These similarities+are abstracted in the MonadSnaplet type class.++During initialization, sometimes you want to modify the result of another+snaplet's initialization.  For instance, maybe you want to add templates or+bind splices for a sitewide Heist snaplet.  Or perhaps you want to add+controls to the admin panel snaplet.  This involves modifying the state of+other snaplets.  It would be nice to use the same lenses and scoped+modification via top-level state that we use in `Handler`.  But in the+initializer we don't yet have a fully constructed top-level state object to+modify.  So instead of actually modifying the state directly, we construct+modifier functions to be applied at the end of initialization.  Since these+functions form a monoid, we can build them up using WriterT as LensT's+underlying monad.++The `Initializer` monad is used for both initialization and application+reloading.  When an application is reloaded from the browser, status and error+messages should go to the browser instead of the console.  The printInfo+function sends messages to the appropriate place and should be used to+communicate all initializer status and errors.++## Heist++The Heist snaplet is a fairly complex snaplet that illustrates a number of+concepts that you may encounter while writing your own snaplets.  The biggest+issue arises because Heist's TemplateState is parameterized by the handler+monad.  This means that if you want to do something like a with transformation+with a lens `Lens b v` you will naturally want to apply the same+transformation to the Handler parameter of the TemplateState.  Unfortunately,+due to Heist's design, this is computationally intensive, must be performed at+runtime, and requires that you have a bijection between b and v.  To avoid+this issue, we only use the base application state, `TemplateState (Handler b+b)`.++The basic functions for manipulating templates are not affected by this+decision.  But the splice functions are more problematic since they are the+ones that actually use TemplateState's monad parameter.++You will also notice that the Heist snaplet includes a HasHeist type class.+Normally to use snaplets, you must "call" them using with or withTop,+passing the lens to the desired snaplet.  This is useful because it allows you+to have multiple instances of the same snaplet.  However, there may be times+when you know you will only ever need a single instance of a particular+snaplet and you'd like to avoid the need to manually change the context every+time.++This is where type classes are useful.  The HasHeist type class essentially+defines some global compile-time state associating a particular lens to be+used for calls to Heist within a particular type.  To use Heist, just define a+HasHeist instance for your application or snaplet type and all the Heist API+functions will work without needing with.  Your HasHeist instance will+look something like this:++    instance HasHeist App where+        heistLens = subSnaplet heist++The call to subSnaplet is required because HasHeist needs a `Lens+(Snaplet v) (Snaplet (Heist b))` instead of the lens `Lens v (Snaplet (Heist+b))` that you willll get from mkLabels.+
+ haddock.sh view
@@ -0,0 +1,10 @@+#!/bin/sh++set -x++HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html --css=extra/haddock.css'++cabal haddock $HADDOCK_OPTS --hyperlink-source $@++cp extra/logo.gif dist/doc/html/snap/haskell_icon.gif+cp extra/hscolour.css dist/doc/html/snap/src/
− project_template/barebones/.ghci 
@@ -1,4 +0,0 @@-:set -isrc-:set -hide-package MonadCatchIO-mtl-:set -hide-package monads-fd-:set -XOverloadedStrings
− project_template/barebones/foo.cabal 
@@ -1,29 +0,0 @@-Name:                projname-Version:             0.1-Synopsis:            Project Synopsis Here-Description:         Project Description Here-License:             AllRightsReserved-Author:              Author-Maintainer:          maintainer@example.com-Stability:           Experimental-Category:            Web-Build-type:          Simple-Cabal-version:       >=1.2--Executable projname-  hs-source-dirs: src-  main-is: Main.hs--  Build-depends:-    base                      >= 4     && < 5,-    bytestring                >= 0.9.1 && < 0.11,-    MonadCatchIO-transformers >= 0.2.1 && < 0.4,-    mtl                       >= 2     && < 3,-    snap-core                 >= 0.9   && < 0.10,-    snap-server               >= 0.9   && < 0.10--  if impl(ghc >= 6.12.0)-    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-unused-do-bind-  else-    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
− project_template/barebones/log/access.log 
− project_template/barebones/src/Main.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where--import           Control.Applicative-import           Snap.Core-import           Snap.Util.FileServe-import           Snap.Http.Server--main :: IO ()-main = quickHttpServe site--site :: Snap ()-site =-    ifTop (writeBS "hello world") <|>-    route [ ("foo", writeBS "bar")-          , ("echo/:echoparam", echoHandler)-          ] <|>-    dir "static" (serveDirectory ".")--echoHandler :: Snap ()-echoHandler = do-    param <- getParam "echoparam"-    maybe (writeBS "must specify echo/param in URL")-          writeBS param
− project_template/default/.ghci 
@@ -1,4 +0,0 @@-:set -isrc-:set -hide-package MonadCatchIO-mtl-:set -hide-package monads-fd-:set -XOverloadedStrings
− project_template/default/foo.cabal 
@@ -1,63 +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--Flag old-base-  default: False-  manual: False--Executable projname-  hs-source-dirs: src-  main-is: Main.hs--  Build-depends:-    bytestring                >= 0.9.1   && < 0.11,-    heist                     >= 0.14    && < 0.15,-    MonadCatchIO-transformers >= 0.2.1   && < 0.4,-    mtl                       >= 2       && < 3,-    snap                      >= 0.13    && < 0.15,-    snap-core                 >= 0.9     && < 0.10,-    snap-server               >= 0.9     && < 0.10,-    snap-loader-static        >= 0.9     && < 0.10,-    text                      >= 0.11    && < 1.3,-    time                      >= 1.1     && < 1.6,-    xmlhtml                   >= 0.1     && < 0.3--  if flag(old-base)-    build-depends:-      base                      >= 4        && < 4.4,-      lens                      >= 3.7.6    && < 3.8-  else-    build-depends:-      base                      >= 4.4      && < 5,-      lens                      >= 3.7.6    && < 4.13--  if flag(development)-    build-depends:-      snap-loader-dynamic == 0.10.*-    cpp-options: -DDEVELOPMENT-    -- In development mode, speed is already going to suffer, so skip-    -- the fancy optimization flags.  Additionally, disable all-    -- warnings.  The hint library doesn't give an option to execute-    -- compiled code when there were also warnings, so disabling-    -- warnings allows quicker workflow.-    ghc-options: -threaded -w-  else-    if impl(ghc >= 6.12.0)-      ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2-                   -fno-warn-orphans -fno-warn-unused-do-bind-    else-      ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2-                   -fno-warn-orphans
− project_template/default/log/access.log 
− project_template/default/log/error.log 
− project_template/default/snaplets/heist/templates/_login.tpl 
@@ -1,9 +0,0 @@-<h1>Snap Example App Login</h1>--<p><loginError/></p>--<bind tag="postAction">/login</bind>-<bind tag="submitText">Login</bind>-<apply template="userform"/>--<p>Don't have a login yet? <a href="/new_user">Create a new user</a></p>
− project_template/default/snaplets/heist/templates/_new_user.tpl 
@@ -1,5 +0,0 @@-<h1>Register a new user</h1>--<bind tag="postAction">/new_user</bind>-<bind tag="submitText">Add User</bind>-<apply template="userform"/>
− project_template/default/snaplets/heist/templates/base.tpl 
@@ -1,13 +0,0 @@-<html>-  <head>-    <title>Snap web server</title>-    <link rel="stylesheet" type="text/css" href="/screen.css"/>-  </head>-  <body>-    <div id="content">--      <apply-content/>--    </div>-  </body>-</html>
− project_template/default/snaplets/heist/templates/index.tpl 
@@ -1,19 +0,0 @@-<apply template="base">--  <ifLoggedIn>-    <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>Congrats!  You're logged in as '<loggedInUser/>'</p>--    <p><a href="/logout">Logout</a></p>-  </ifLoggedIn>--  <ifLoggedOut>-    <apply template="_login"/>-  </ifLoggedOut>--</apply>
− project_template/default/snaplets/heist/templates/login.tpl 
@@ -1,3 +0,0 @@-<apply template="base">-  <apply template="_login"/>-</apply>
− project_template/default/snaplets/heist/templates/new_user.tpl 
@@ -1,3 +0,0 @@-<apply template="base">-  <apply template="_new_user" />-</apply>
− project_template/default/snaplets/heist/templates/userform.tpl 
@@ -1,14 +0,0 @@-<form method="post" action="${postAction}">-  <table id="info">-    <tr>-      <td>Login:</td><td><input type="text" name="login" size="20" /></td>-    </tr>-    <tr>-      <td>Password:</td><td><input type="password" name="password" size="20" /></td>-    </tr>-    <tr>-      <td></td>-      <td><input type="submit" value="${submitText}" /></td>-    </tr>-  </table>-</form>
− project_template/default/src/Application.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}----------------------------------------------------------------------------------- | This module defines our application's state type and an alias for its--- handler monad.-module Application where---------------------------------------------------------------------------------import Control.Lens-import Snap.Snaplet-import Snap.Snaplet.Heist-import Snap.Snaplet.Auth-import Snap.Snaplet.Session---------------------------------------------------------------------------------data App = App-    { _heist :: Snaplet (Heist App)-    , _sess :: Snaplet SessionManager-    , _auth :: Snaplet (AuthManager App)-    }--makeLenses ''App--instance HasHeist App where-    heistLens = subSnaplet heist----------------------------------------------------------------------------------type AppHandler = Handler App App--
− project_template/default/src/Main.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE TemplateHaskell #-}--{---NOTE: Don't modify this file unless you know what you are doing.  If you are-new to snap, start with Site.hs and Application.hs.  This file contains-boilerplate needed for dynamic reloading and is not meant for general-consumption.--Occasionally if we modify the way the dynamic reloader works and you want to-upgrade, you might have to swap out this file for a newer version.  But in-most cases you'll never need to modify this code.---}-module Main where---------------------------------------------------------------------------------import           Control.Exception (SomeException, try)-import qualified Data.Text as T-import           Snap.Http.Server-import           Snap.Snaplet-import           Snap.Snaplet.Config-import           Snap.Core-import           System.IO-import           Site--#ifdef DEVELOPMENT-import           Snap.Loader.Dynamic-#else-import           Snap.Loader.Static-#endif------------------------------------------------------------------------------------ | This is the entry point for this web server application. It supports--- easily switching between interpreting source and running statically compiled--- code.------ In either mode, the generated program should be run from the root of the--- project tree. When it is run, it locates its templates, static content, and--- source files in development mode, relative to the current working directory.------ When compiled with the development flag, only changes to the libraries, your--- cabal file, or this file should require a recompile to be picked up.--- Everything else is interpreted at runtime. There are a few consequences of--- this.------ First, this is much slower. Running the interpreter takes a significant--- chunk of time (a couple tenths of a second on the author's machine, at this--- time), regardless of the simplicity of the loaded code. In order to--- recompile and re-load server state as infrequently as possible, the source--- directories are watched for updates, as are any extra directories specified--- below.------ Second, the generated server binary is MUCH larger, since it links in the--- GHC API (via the hint library).------ Third, and the reason you would ever want to actually compile with--- development mode, is that it enables a faster development cycle. You can--- simply edit a file, save your changes, and hit reload to see your changes--- reflected immediately.------ When this is compiled without the development flag, all the actions are--- statically compiled in. This results in faster execution, a smaller binary--- size, and having to recompile the server for any code change.----main :: IO ()-main = do-    -- Depending on the version of loadSnapTH in scope, this either enables-    -- dynamic reloading, or compiles it without. The last argument to-    -- loadSnapTH is a list of additional directories to watch for changes to-    -- trigger reloads in development mode. It doesn't need to include source-    -- directories, those are picked up automatically by the splice.-    (conf, site, cleanup) <- $(loadSnapTH [| getConf |]-                                          'getActions-                                          ["snaplets/heist/templates"])--    _ <- try $ httpServe conf site :: IO (Either SomeException ())-    cleanup------------------------------------------------------------------------------------ | This action loads the config used by this application. The loaded config--- is returned as the first element of the tuple produced by the loadSnapTH--- Splice. The type is not solidly fixed, though it must be an IO action that--- produces the same type as 'getActions' takes. It also must be an instance of--- Typeable. If the type of this is changed, a full recompile will be needed to--- pick up the change, even in development mode.------ This action is only run once, regardless of whether development or--- production mode is in use.-getConf :: IO (Config Snap AppConfig)-getConf = commandLineAppConfig defaultConfig------------------------------------------------------------------------------------ | This function generates the the site handler and cleanup action from the--- configuration. In production mode, this action is only run once. In--- development mode, this action is run whenever the application is reloaded.------ Development mode also makes sure that the cleanup actions are run--- appropriately before shutdown. The cleanup action returned from loadSnapTH--- should still be used after the server has stopped handling requests, as the--- cleanup actions are only automatically run when a reload is triggered.------ This sample doesn't actually use the config passed in, but more--- sophisticated code might.-getActions :: Config Snap AppConfig -> IO (Snap (), IO ())-getActions conf = do-    (msgs, site, cleanup) <- runSnaplet-        (appEnvironment =<< getOther conf) app-    hPutStrLn stderr $ T.unpack msgs-    return (site, cleanup)
− project_template/default/src/Site.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}----------------------------------------------------------------------------------- | This module is where all the routes and handlers are defined for your--- site. The 'app' function is the initializer that combines everything--- together and is exported by this module.-module Site-  ( app-  ) where---------------------------------------------------------------------------------import           Control.Applicative-import           Data.ByteString (ByteString)-import           Data.Monoid-import qualified Data.Text as T-import           Snap.Core-import           Snap.Snaplet-import           Snap.Snaplet.Auth-import           Snap.Snaplet.Auth.Backends.JsonFile-import           Snap.Snaplet.Heist-import           Snap.Snaplet.Session.Backends.CookieSession-import           Snap.Util.FileServe-import           Heist-import qualified Heist.Interpreted as I--------------------------------------------------------------------------------import           Application------------------------------------------------------------------------------------ | Render login form-handleLogin :: Maybe T.Text -> Handler App (AuthManager App) ()-handleLogin authError = heistLocal (I.bindSplices errs) $ render "login"-  where-    errs = maybe mempty splice authError-    splice err = "loginError" ## I.textSplice err------------------------------------------------------------------------------------ | Handle login submit-handleLoginSubmit :: Handler App (AuthManager App) ()-handleLoginSubmit =-    loginUser "login" "password" Nothing-              (\_ -> handleLogin err) (redirect "/")-  where-    err = Just "Unknown user or password"------------------------------------------------------------------------------------ | Logs out and redirects the user to the site index.-handleLogout :: Handler App (AuthManager App) ()-handleLogout = logout >> redirect "/"------------------------------------------------------------------------------------ | Handle new user form submit-handleNewUser :: Handler App (AuthManager App) ()-handleNewUser = method GET handleForm <|> method POST handleFormSubmit-  where-    handleForm = render "new_user"-    handleFormSubmit = registerUser "login" "password" >> redirect "/"------------------------------------------------------------------------------------ | The application's routes.-routes :: [(ByteString, Handler App App ())]-routes = [ ("/login",    with auth handleLoginSubmit)-         , ("/logout",   with auth handleLogout)-         , ("/new_user", with auth handleNewUser)-         , ("",          serveDirectory "static")-         ]------------------------------------------------------------------------------------ | The application initializer.-app :: SnapletInit App App-app = makeSnaplet "app" "An snaplet example application." Nothing $ do-    h <- nestSnaplet "" heist $ heistInit "templates"-    s <- nestSnaplet "sess" sess $-           initCookieSessionManager "site_key.txt" "sess" (Just 3600)--    -- NOTE: We're using initJsonFileAuthManager here because it's easy and-    -- doesn't require any kind of database server to run.  In practice,-    -- you'll probably want to change this to a more robust auth backend.-    a <- nestSnaplet "auth" auth $-           initJsonFileAuthManager defAuthSettings sess "users.json"-    addRoutes routes-    addAuthSplices h auth-    return $ App h s a-
− project_template/default/static/screen.css 
@@ -1,26 +0,0 @@-html {-   padding: 0;-   margin: 0;-   background-color: #ffffff;-   font-family: Verdana, Helvetica, sans-serif;-}-body {-   padding: 0;-   margin: 0;-}-a {-   text-decoration: underline;-}-a :hover {-   cursor: pointer;-   text-decoration: underline;-}-img {-   border: none;-}-#content {-   padding-left: 1em;-}-#info {-   font-size: 60%;-}
− project_template/tutorial/.ghci 
@@ -1,4 +0,0 @@-:set -isrc-:set -hide-package MonadCatchIO-mtl-:set -hide-package monads-fd-:set -XOverloadedStrings
− project_template/tutorial/foo.cabal 
@@ -1,42 +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 old-base-  default: False-  manual: False--Executable projname-  hs-source-dirs: src-  main-is: Tutorial.lhs--  Build-depends:-    bytestring                >= 0.9.1   && < 0.11,-    MonadCatchIO-transformers >= 0.2.1   && < 0.4,-    mtl                       >= 2       && < 3,-    snap                      >= 0.11    && < 0.15,-    snap-core                 >= 0.9     && < 0.10,-    snap-server               >= 0.9     && < 0.10--  if flag(old-base)-    build-depends:-      base                      >= 4        && < 4.4,-      lens                      >= 3.7.6    && < 3.8-  else-    build-depends:-      base                      >= 4.4      && < 5,-      lens                      >= 3.7.6    && < 4.13--  if impl(ghc >= 6.12.0)-    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-unused-do-bind-  else-    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
− project_template/tutorial/log/placeholder 
@@ -1,1 +0,0 @@-placeholder
− project_template/tutorial/src/Part2.lhs 
@@ -1,16 +0,0 @@-> {-# LANGUAGE OverloadedStrings #-}-> module Part2 where--> import           Snap.Snaplet--> data Foo = Foo-> -> data Bar = Bar-> -> fooInit :: SnapletInit b Foo-> fooInit = makeSnaplet "foo" "Foo snaplet" Nothing $ do->     return Foo-> -> barInit :: SnapletLens b Foo -> SnapletInit b Bar-> barInit h = makeSnaplet "bar" "Bar snaplet" Nothing $ do->     return Bar
− project_template/tutorial/src/Tutorial.lhs 
@@ -1,366 +0,0 @@-What Are Snaplets?-==================--A snaplet is a composable web application.  Snaplets allow you to build-self-contained pieces of functionality and glue them together to make larger-applications.  Here are some of the things provided by the snaplet API:--  - Infrastructure for application state/environment--  - Snaplet initialization, reload, and cleanup--  - Management of filesystem data and automatic snaplet installation--  - Unified config file infrastructure--One example might be a wiki snaplet.  It would be distributed as a haskell-package that would be installed with cabal and would probably include code,-config files, HTML templates, stylesheets, JavaScript, images, etc.  The-snaplet's code would provide the necessary API to let your application-interact seamlessly with the wiki functionality.  When you run your-application for the first time, all of the wiki snaplet's filesystem resources-will automatically be copied into the appropriate places.  Then you will-immediately be able to customize the wiki to fit your needs by editing config-files, providing your own stylesheets, etc.  We will discuss this in more-detail later.--A snaplet can represent anything from backend Haskell infrastructure with no-user facing functionality to a small widget like a chat box that goes in the-corner of a web page to an entire standalone website like a blog or forum.-The possibilities are endless.  A snaplet is a web application, and web-applications are snaplets.  This means that using snaplets and writing-snaplets are almost the same thing, and it's trivial to drop a whole website-into another one.--We're really excited about the possibilities available with snaplets.  In-fact, Snap already ships with snaplets for sessions, authentication, and-templating (with Heist),  This gives you useful functionality out of the box,-and jump starts your own snaplet development by demonstrating some useful-design patterns.  So without further ado, let's get started.--Snaplet Overview-================--The heart of the snaplets infrastructure is state management.  Most nontrivial-pieces of a web app need some kind of state or environment data.  Components-that do not need any kind of state or environment are probably more-appropriate as a standalone library than as a snaplet.--Before we continue, we must clarify an important point.  The Snap web server-processes each request in its own green thread.  This means that each request-will receive a separate copy of the state defined by your application and-snaplets, and modifications to that state only affect the local thread that-generates a single response.  From now on, when we talk about state this is-what we are talking about.  If you need global application state, you have to-use a thread-safe construct such as an MVar or IORef.--This post is written in literate Haskell.  It uses a small external module-called Part2 that is [available-here](https://github.com/snapframework/snap/blob/master/project_template/tutorial/src/Part2.lhs).-You can also install the full code in the current directory with the command-`snap init tutorial`.  First we need to get imports out of the way.--> {-# LANGUAGE TemplateHaskell #-}-> {-# LANGUAGE OverloadedStrings #-}-> -> module Main where-> -> import           Control.Applicative-> import           Control.Lens.TH-> import           Control.Monad.State-> import           Control.Monad.Trans-> import qualified Data.ByteString.Char8 as B-> import           Data.IORef-> import           Data.Maybe-> import           Snap-> import           Snap.Snaplet.Heist-> import           Part2--We start our application by defining a data structure to hold the state.  This-data structure includes the state of all snaplets (wrapped in a Snaplet) used-by our application as well as any other state we might want.--> data App = App->     { _heist       :: Snaplet (Heist App)->     , _foo         :: Snaplet Foo->     , _bar         :: Snaplet Bar->     , _companyName :: IORef B.ByteString->     }->-> makeLenses ''App--The field names begin with an underscore because of some more complicated-things going on under the hood.  However, all you need to know right now is-that you should prefix things with an underscore and then call `makeLenses`.-This lets you use the names without an underscore in the rest of your-application.--The next thing we need to do is define an initializer.--> appInit :: SnapletInit App App-> appInit = makeSnaplet "myapp" "My example application" Nothing $ do->     hs <- nestSnaplet "heist" heist $ heistInit "templates"->     fs <- nestSnaplet "foo" foo $ fooInit->     bs <- nestSnaplet "" bar $ nameSnaplet "newname" $ barInit foo->     addRoutes [ ("/hello", writeText "hello world")->               , ("/fooname", with foo namePage)->               , ("/barname", with bar namePage)->               , ("/company", companyHandler)->               ]->     wrapSite (<|> heistServe)->     ref <- liftIO $ newIORef "fooCorp"->     return $ App hs fs bs ref--For now don't worry about all the details of this code.  We'll work through the-individual pieces one at a time.  The basic idea here is that to initialize an-application, we first initialize each of the snaplets, add some routes, run a-function wrapping all the routes, and return the resulting state data-structure.  This example demonstrates the use of a few of the most common-snaplet functions.--nestSnaplet-------------   -All calls to child snaplet initializer functions must be wrapped in a call to-nestSnaplet.  The first parameter is a URL path segment that is used to prefix-all routes defined by the snaplet.  This lets you ensure that there will be no-problems with duplicate routes defined in different snaplets.  If the foo-snaplet defines a route `/foopage`, then in the above example, that page will-be available at `/foo/foopage`.  Sometimes though, you might want a snaplet's-routes to be available at the top level.  To do that, just pass an empty string-to nestSnaplet as shown above with the bar snaplet.--In our example above, the bar snaplet does something that needs to know about-the foo snaplet.  Maybe foo is a database snaplet and bar wants to store or-read something.  In order to make that happen, it needs to have a "handle" to-the snaplet.  Our handles are whatever field names we used in the App data-structure minus the initial underscore character.  They are automatically-generated by the `makeLenses` function.  For now it's sufficient to think of-them as a getter and a setter combined (to use an OO metaphor).--The second parameter to nestSnaplet is the lens to the snaplet you're nesting.-In order to place a piece into the puzzle, you need to know where it goes.--nameSnaplet--------------The author of a snaplet defines a default name for the snaplet in the first-argument to the makeSnaplet function.  This name is used for the snaplet's-directory in the filesystem.  If you don't want to use the default name, you-can override it with the `nameSnaplet` function.  Also, if you want to have two-instances of the same snaplet, then you will need to use `nameSnaplet` to give-at least one of them a unique name.--addRoutes------------The `addRoutes` function is how an application (or snaplet) defines its-routes.  Under the hood the snaplet infrastructure merges all the routes from-all snaplets, prepends prefixes from `nestSnaplet` calls, and passes the list-to Snap's-[route](http://hackage.haskell.org/packages/archive/snap-core/0.5.1.4/doc/html/Snap-Types.html#v:route)-function.--A route is a tuple of a URL and a handler function that will be called when-the URL is requested.  Handler is a wrapper around the Snap monad that handles-the snaplet's infrastructure.  During initialization, snaplets use the-`Initializer` monad.  During runtime, they use the `Handler` monad.  We'll-discuss `Handler` in more detail later.  If you're familiar with Snap's old-extension system, you can think of it as roughly equivalent to the Application-monad.  It has a `MonadState` instance that lets you access and modify the-current snaplet's state, and a `MonadSnap` instance providing the-request-processing functions defined in Snap.Types.--wrapSite---------------`wrapSite` allows you to apply an arbitrary `Handler` transformation to-the top-level handler.  This is useful if you want to do some generic-processing at the beginning or end of every request.  For instance, a session-snaplet might use it to touch a session activity token before routing happens.-It could also be used to implement custom logging.  The example above uses it-to define heistServe (provided by the Heist snaplet) as the default handler to-be tried if no other handler matched.  This may seem like an easy way to define-routes, but if you string them all together in this way each handler will be-evaluated sequentially and you'll get O(n) time complexity, whereas routes-defined with `addRoutes` have O(log n) time complexity.  Therefore, in a-real-world application you would probably want to have `("", heistServe)` in-the list passed to `addRoutes`.--with-------The last unfamiliar function in the example is `with`.  Here it accompanies a-call to the function `namePage`.  `namePage` is a simple example handler and-looks like this.--> namePage :: Handler b v ()-> namePage = do->     mname <- getSnapletName->     writeText $ fromMaybe "This shouldn't happen" mname--This function is a generic handler that gets the name of the current snaplet-and writes it into the response with the `writeText` function defined by the-snap-core project.  The type variables 'b' and 'v' indicate that this function-will work in any snaplet with any base application.  The 'with' function is-used to run `namePage` in the context of the snaplets foo and bar for the-corresponding routes.  --Site Reloading-----------------Snaplet Initializers serve dual purpose as both initializers and reloaders.-Reloads are triggered by a special handler that is bound to the-`/admin/reload` route.  This handler re-runs the site initializer and if it is-successful, loads the newly generated in-memory state.  To prevent denial of-service attacks, the reload route is only accessible from localhost.--If there are any errors during reload, you would naturally want to see them in-the HTTP response returned by the server.  However, when these same-initializers are run when you first start your app, you will want to see-status messages printed to the console.  To make this possible we provide the-`printInfo` function.  You should use it to output any informational messages-generated by your initializers.  If you print directly to standard output or-standard error, then those messages will not be available in your browser when-you reload the site.--Working with state---------------------`Handler b v` has a `MonadState v` instance.  This means that you can access-all your snaplet state through the get, put, gets, and modify functions that-are probably familiar from the state monad.  In our example application we-demonstrate this with `companyHandler`.--> companyHandler :: Handler App App ()-> companyHandler = method GET getter <|> method POST setter->   where->     getter = do->         nameRef <- gets _companyName->         name <- liftIO $ readIORef nameRef->         writeBS name->     setter = do->         mname <- getParam "name"->         nameRef <- gets _companyName->         liftIO $ maybe (return ()) (writeIORef nameRef) mname->         getter--If you set a GET request to `/company`, you'll get the string "fooCorp" back.-If you send a POST request, it will set the IORef held in the `_companyName`-field in the `App` data structure to the value of the `name` field.  Then it-calls the getter to return that value back to you so you can see it was-actually changed.  Again, remember that this change only persists across-requests because we used an IORef.  If `_companyName` was just a plain string-and we had used modify, the changed result would only be visible in the rest-of the processing for that request.--The Heist Snaplet-=================--The astute reader might ask why there is no `with heist` in front of the call-to `heistServe`.  And indeed, that would normally be the case.  But we decided-that an application will never need more than one instance of a Heist snaplet.-So we provided a type class called `HasHeist` that allows an application to-define the global reference to its Heist snaplet by writing a `HasHeist`-instance.  In this example we define the instance as follows:--> instance HasHeist App where heistLens = subSnaplet heist--Now all we need is a simple main function to serve our application.--> main :: IO ()-> main = serveSnaplet defaultConfig appInit--This completes a full working application.  We did leave out a little dummy-code for the Foo and Bar snaplets.  This code is included in Part2.hs.  For-more information look in our [API-documentation](http://hackage.haskell.org/package/snap), specifically the-Snap.Snaplet module.  No really, that wasn't a joke.  The API docs are written-as prose.  They should be very easy to read, while having the benefit of-including all the actual type signatures.--Filesystem Data and Automatic Installation-==========================================--Some snaplets will have data stored in the filesystem that should be installed-into the directory of any project that uses it.  Here's an example of what a-snaplet filesystem layout might look like:--    foosnaplet/-      |-- *devel.cfg*-      |-- db.cfg-      |-- public/-          |-- stylesheets/-          |-- images/-          |-- js/-      |-- *snaplets/*-          |-- *heist/*-              |-- templates/-          |-- subsnaplet1/-          |-- subsnaplet2/--Only the starred items are actually enforced by current code, but we want to-establish the others as a convention.  The file devel.cfg is automatically-read by the snaplet infrastructure.  It is available to you via the-`getSnapletUserConfig` function.  Config files use the format defined by Bryan-O'Sullivan's excellent [configurator-package](http://hackage.haskell.org/package/configurator).  In this example,-the user has chosen to put db config items in a separate file and use-configurator's import functionality to include it in devel.cfg.  If-foosnaplet uses `nestSnaplet` or `embedSnaplet` to include any other snaplets,-then filesystem data defined by those snaplets will be included in-subdirectories under the `snaplets/` directory.--So how do you tell the snaplet infrastructure that your snaplet has filesystem-data that should be installed?  Look at the definition of appInit above.  The-third argument to the makeSnaplet function is where we specify the filesystem-directory that should be installed.  That argument has the type `Maybe (IO-FilePath)`.  In this case we used `Nothing` because our simple example doesn't-have any filesystem data.  As an example, let's say you are creating a snaplet-called killerapp that will be distributed as a hackage project called-snaplet-killerapp.  Your project directory structure will look something like-this:--    snaplet-killerapp/-      |-- resources/-      |-- snaplet-killerapp.cabal-      |-- src/--All of the files and directories listed above under foosnaplet/ will be in-resources/.  Somewhere in the code you will define an initializer for the-snaplet that will look like this:--    killerInit = makeSnaplet "killerapp" "42" (Just dataDir) $ do--The primary function of Cabal is to install code.  But it has the ability to-install data files and provides a function called `getDataDir` for retrieving-the location of these files.  Since it returns a different result depending on-what machine you're using, the third argument to `makeSnaplet` has to be `Maybe-(IO FilePath)` instead of the more natural pure version.  To make things more-organized, we use the convention of putting all your snaplet's data files in a-subdirectory called resources.  So we need to create a small function that-appends `/resources` to the result of `getDataDir`.--    import Paths_snaplet_killerapp-    dataDir = liftM (++"/resources") getDataDir--If our project is named snaplet-killerapp, the `getDataDir` function is-defined in the module Paths_snaplet_killerapp, which we have to import.  To-make everything work, you have to tell Cabal about your data files by-including a section like the following in snaplet-killerapp.cabal:--    data-files:-      resources/devel.cfg,-      resources/public/stylesheets/style.css,-      resources/snaplets/heist/templates/page.tpl--Now whenever your snaplet is used, its filesystem data will be automagically-copied into the local project that is using it, whenever the application is-run and it sees that the snaplet's directory does not already exist.  If the-user upgrades to a new version of the snaplet and the new version made changes-to the filesystem resources, those resources will NOT be automatically copied-in by default.  Resource installation *only* happens when the `snaplets/foo`-directory does not exist.  If you want to get the latest version of the-filesystem resources, remove the `snaplets/foo` directory, and restart your-app.-
+ 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,5 +1,6 @@+cabal-version:  2.2 name:           snap-version:        0.14.0.7+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.@@ -7,13 +8,11 @@     .     * The Snaplets API     .-    * The \"snap\" executable program for generating starter projects-    .     * Snaplets for sessions, authentication, and templates     .     To get started, issue the following sequence of commands:     .-    @$ cabal install snap+    @$ cabal install snap snap-templates     $ mkdir myproject     $ cd myproject     $ snap init@@@ -21,93 +20,98 @@     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:        BSD3+license:        BSD-3-Clause license-file:   LICENSE-author:         Ozgun Ataman, Doug Beardsley, Gregory Collins, Carl Howells, Chris Smith+author:         Ozgun Ataman, Doug Beardsley,+                Gregory Collins, Carl Howells, Chris Smith maintainer:     snap@snapframework.com build-type:     Simple-cabal-version:  >= 1.8 homepage:       http://snapframework.com/+bug-reports:    https://github.com/snapframework/snap/issues category:       Web, Snap +tested-with:+  GHC == 8.8.4+  GHC == 8.10.7+  GHC == 9.0.2+  GHC == 9.2.8+  GHC == 9.4.5+  GHC == 9.6.2+ extra-source-files:-  CHANGELOG.md,+  .ghci,   CONTRIBUTORS,   LICENSE,   README.md,   README.SNAP.md,-  project_template/barebones/.ghci,-  project_template/barebones/foo.cabal,-  project_template/barebones/log/access.log,-  project_template/barebones/src/Main.hs,-  project_template/default/.ghci,-  project_template/default/foo.cabal,-  project_template/default/log/access.log,-  project_template/default/log/error.log,-  project_template/default/static/screen.css,-  project_template/default/snaplets/heist/templates/base.tpl,-  project_template/default/snaplets/heist/templates/index.tpl,-  project_template/default/snaplets/heist/templates/_login.tpl,-  project_template/default/snaplets/heist/templates/login.tpl,-  project_template/default/snaplets/heist/templates/_new_user.tpl,-  project_template/default/snaplets/heist/templates/new_user.tpl,-  project_template/default/snaplets/heist/templates/userform.tpl,-  project_template/default/src/Application.hs,-  project_template/default/src/Main.hs,-  project_template/default/src/Site.hs,-  project_template/tutorial/.ghci,-  project_template/tutorial/foo.cabal,-  project_template/tutorial/log/placeholder,-  project_template/tutorial/src/Part2.lhs,-  project_template/tutorial/src/Tutorial.lhs,+  changelog.md,+  design.md,   extra/hscolour.css,   extra/haddock.css,   extra/logo.gif,-  test/snap-testsuite.cabal,-  test/runTestsAndCoverage.sh,-  test/suite/TestSuite.hs,-  test/suite/NestTest.hs,-  test/suite/Snap/TestCommon.hs,-  test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs,-  test/suite/Snap/Snaplet/Internal/RST/Tests.hs,-  test/suite/Snap/Snaplet/Internal/Tests.hs,-  test/suite/Snap/Snaplet/Internal/LensT/Tests.hs,-  test/suite/Blackbox/Types.hs,-  test/suite/Blackbox/FooSnaplet.hs,-  test/suite/Blackbox/BarSnaplet.hs,-  test/suite/Blackbox/Common.hs,-  test/suite/Blackbox/EmbeddedSnaplet.hs,-  test/suite/Blackbox/Tests.hs,-  test/suite/Blackbox/App.hs,-  test/suite/SafeCWD.hs,-  test/suite/AppMain.hs,-  test/non-cabal-appdir/db.cfg,-  test/non-cabal-appdir/bad.tpl,-  test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl,-  test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl,-  test/non-cabal-appdir/snaplets/baz/devel.cfg,-  test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl,-  test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl,-  test/non-cabal-appdir/snaplets/heist/templates/index.tpl,-  test/non-cabal-appdir/snaplets/heist/templates/session.tpl,-  test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl,-  test/non-cabal-appdir/snaplets/heist/templates/page.tpl,-  test/non-cabal-appdir/good.tpl,-  test/non-cabal-appdir/log/placeholder,-  test/non-cabal-appdir/devel.cfg,-  test/foosnaplet/templates/foopage.tpl,-  test/foosnaplet/devel.cfg+  haddock.sh,+  runTestsAndCoverage.sh,+  test/bad.tpl,+  test/db.cfg,+  test/devel.cfg,+  test/good.tpl,+  test/snaplets/baz/devel.cfg,+  test/snaplets/baz/templates/bazconfig.tpl,+  test/snaplets/baz/templates/bazpage.tpl,+  test/snaplets/embedded/extra-templates/extra.tpl,+  test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl,+  test/snaplets/foosnaplet/devel.cfg,+  test/snaplets/foosnaplet/templates/foopage.tpl,+  test/snaplets/heist/templates/_foopage.tpl,+  test/snaplets/heist/templates/extraTemplates/barpage.tpl,+  test/snaplets/heist/templates/foopage.tpl,+  test/snaplets/heist/templates/index.tpl,+  test/snaplets/heist/templates/page.tpl,+  test/snaplets/heist/templates/session.tpl,+  test/snaplets/heist/templates/splicepage.tpl,+  test/snaplets/heist/templates/userpage.tpl -Flag old-base-  default: False-  manual: False+common universal+  default-language: Haskell2010 +  build-depends:+    , base >= 4.5 && < 5++  if !impl(ghc >= 8.0)+    build-depends:+      , semigroups >= 0.16 && < 0.19+      , fail       >= 4.9  && < 4.10++  default-extensions:+    BangPatterns+    CPP+    DeriveDataTypeable+    ExistentialQuantification+    FlexibleContexts+    FlexibleInstances+    GeneralizedNewtypeDeriving+    MultiParamTypeClasses+    NoMonomorphismRestriction+    OverloadedStrings+    PackageImports+    Rank2Types+    RecordWildCards+    ScopedTypeVariables+    TemplateHaskell+    TypeFamilies+    TypeOperators+    TypeSynonymInstances+ Library+  import: universal   hs-source-dirs: src    exposed-modules:-    Snap,+    Snap     Snap.Snaplet     Snap.Snaplet.Heist     Snap.Snaplet.HeistNoClass@@ -124,17 +128,10 @@     Snap.Snaplet.Test    other-modules:-    Control.Access.RoleBased.Checker-    Control.Access.RoleBased.Role-    Control.Access.RoleBased.Types-    Control.Access.RoleBased.Internal.Role-    Control.Access.RoleBased.Internal.RoleMap-    Control.Access.RoleBased.Internal.Rule-    Control.Access.RoleBased.Internal.Types+    Paths_snap     Snap.Snaplet.Auth.AuthManager     Snap.Snaplet.Auth.Types     Snap.Snaplet.Auth.Handlers-    Snap.Snaplet.Auth.Handlers.Errors     Snap.Snaplet.Auth.SpliceHelpers     Snap.Snaplet.Heist.Internal     Snap.Snaplet.Internal.Initializer@@ -145,111 +142,148 @@     Snap.Snaplet.Session.SecureCookie    build-depends:-    MonadCatchIO-transformers >= 0.2      && < 0.4,-    -- Blacklist aeson versions with problems from lack of upper bounds-    aeson                     (>= 0.6 && < 0.7) || (>= 0.7.0.4 && < 0.12),-    attoparsec                >= 0.10     && < 0.14,-    bytestring                >= 0.9.1    && < 0.11,+    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,-    comonad                   >= 1.1      && < 4.3,     configurator              >= 0.1      && < 0.4,-    containers                >= 0.3      && < 0.6,-    directory                 >= 1.0      && < 1.3,+    containers                >= 0.2      && < 0.8,+    directory                 >= 1.1      && < 1.4,     directory-tree            >= 0.11     && < 0.13,-    dlist                     >= 0.5      && < 0.8,-    either                    >= 4.3      && < 4.5,-    filepath                  >= 1.1      && < 1.5,-    -- Blacklist bad versions of hashable-    hashable                  (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),-    heist                     >= 0.14     && < 0.15,-    logict                    >= 0.4.2    && < 0.7,-    mtl                       >  2.0      && < 2.3,-    mwc-random                >= 0.8      && < 0.14,+    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,-    regex-posix               >= 0.95     && < 1,-    snap-core                 >= 0.9      && < 0.11,-    snap-server               >= 0.9      && < 0.11,-    stm                       >= 2.2      && < 2.5,-    text                      >= 0.11     && < 1.3,-    time                      >= 1.1      && < 1.6,-    transformers              >= 0.2      && < 0.5,+    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,-    vector                    >= 0.7.1    && < 0.12,-    vector-algorithms         >= 0.4      && < 0.8,     xmlhtml                   >= 0.1      && < 0.3 --  if flag(old-base)-    build-depends:-      base                      >= 4        && < 4.4,-      lens                      >= 3.7.6    && < 3.8-  else-    build-depends:-      base                      >= 4.4      && < 5,-      lens                      >= 3.7.6    && < 4.14--  extensions:-    BangPatterns,-    CPP,-    DeriveDataTypeable,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses,-    NoMonomorphismRestriction,-    OverloadedStrings,-    PackageImports,-    Rank2Types,-    RecordWildCards,-    ScopedTypeVariables,-    TemplateHaskell,-    TypeFamilies,-    TypeOperators,-    TypeSynonymInstances-   if impl(ghc >= 6.12.0)-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields                  -fno-warn-orphans -fno-warn-unused-do-bind   else-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields                  -fno-warn-orphans -Executable snap-  hs-source-dirs: src-  main-is: Snap/Starter.hs--  other-modules: Snap.StarterTH--  build-depends:-    base                >= 4       && < 5,-    bytestring          >= 0.9.1   && < 0.11,-    containers          >= 0.3     && < 0.6,-    directory           >= 1.0     && < 1.3,-    directory-tree      >= 0.10    && < 0.13,-    filepath            >= 1.1     && < 1.5,-    -- Blacklist bad versions of hashable-    hashable            (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),-    old-time            >= 1.0     && < 1.2,-    snap-server         >= 0.9     && < 0.11,-    template-haskell    >= 2.2     && < 2.11,-    text                >= 0.11    && < 1.3--  extensions:-    OverloadedStrings+Test-suite testsuite+  import: universal+  hs-source-dirs: src test/suite+  type: exitcode-stdio-1.0+  main-is: TestSuite.hs -  other-extensions:-    TemplateHaskell+  autogen-modules:+    Paths_snap -  ghc-prof-options: -prof -auto-all+  other-modules:+    Blackbox.Tests+    Paths_snap+    SafeCWD+    Snap+    Snap.Snaplet+    Snap.Snaplet.Auth+    Snap.Snaplet.Auth.AuthManager+    Snap.Snaplet.Auth.Backends.JsonFile+    Snap.Snaplet.Auth.Handlers+    Snap.Snaplet.Auth.Handlers.Tests+    Snap.Snaplet.Auth.SpliceHelpers+    Snap.Snaplet.Auth.SpliceTests+    Snap.Snaplet.Auth.Tests+    Snap.Snaplet.Auth.Types+    Snap.Snaplet.Auth.Types.Tests+    Snap.Snaplet.Test.Common.App+    Snap.Snaplet.Test.Common.BarSnaplet+    Snap.Snaplet.Test.Common.EmbeddedSnaplet+    Snap.Snaplet.Test.Common.FooSnaplet+    Snap.Snaplet.Test.Common.Handlers+    Snap.Snaplet.Test.Common.Types+    Snap.Snaplet.Config+    Snap.Snaplet.Config.Tests+    Snap.Snaplet.Heist+    Snap.Snaplet.Heist.Compiled+    Snap.Snaplet.Heist.Generic+    Snap.Snaplet.Heist.Internal+    Snap.Snaplet.Heist.Interpreted+    Snap.Snaplet.Heist.Tests+    Snap.Snaplet.HeistNoClass+    Snap.Snaplet.Internal.Initializer+    Snap.Snaplet.Internal.LensT+    Snap.Snaplet.Internal.LensT.Tests+    Snap.Snaplet.Internal.Lensed+    Snap.Snaplet.Internal.Lensed.Tests+    Snap.Snaplet.Internal.RST+    Snap.Snaplet.Internal.RST.Tests+    Snap.Snaplet.Internal.Tests+    Snap.Snaplet.Internal.Types+    Snap.Snaplet.Session+    Snap.Snaplet.Session.Backends.CookieSession+    Snap.Snaplet.Session.Common+    Snap.Snaplet.Session.SecureCookie+    Snap.Snaplet.Session.SessionManager+    Snap.Snaplet.Test+    Snap.Snaplet.Test.Tests+    Snap.TestCommon -  if impl(ghc >= 6.12.0)-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-orphans -fno-warn-unused-do-bind-  else-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-orphans+  build-depends:+    aeson,+    async                      >= 2.0.1.5  && < 2.3,+    attoparsec,+    attoparsec-aeson,+    bytestring,+    cereal,+    clientsession,+    configurator,+    containers,+    deepseq,+    directory,+    directory-tree,+    dlist,+    filepath,+    hashable,+    heist,+    http-streams               >= 0.7.1.1  && < 0.9,+    HUnit                      >= 1.2.5.2  && < 1.7,+    lens,+    lifted-base,+    map-syntax,+    monad-control,+    mtl,+    mwc-random,+    pwstore-fast,+    QuickCheck                 >= 2.4.2    && < 2.15,+    smallcheck                 >= 1.1.1    && < 1.3,+    snap-core,+    snap-server,+    snap,+    stm,+    syb,+    test-framework             >= 0.8.0.3  && < 0.9,+    test-framework-hunit       >= 0.3.0.1  && < 0.4,+    test-framework-quickcheck2 >= 0.3.0.3  && < 0.4,+    test-framework-smallcheck  >= 0.2      && < 0.3,+    text,+    time,+    transformers,+    transformers-base,+    unordered-containers,+    xmlhtml  source-repository head   type:     git
− src/Control/Access/RoleBased/Checker.hs 
@@ -1,224 +0,0 @@-{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE OverloadedStrings #-}--module Control.Access.RoleBased.Checker where---------------------------------------------------------------------------------import           Control.Monad-import           Control.Monad.Logic-import           Control.Monad.Reader-import           Control.Monad.State.Lazy-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.Maybe (fromMaybe, isJust)-import           Data.Text (Text)--------------------------------------------------------------------------------import           Control.Access.RoleBased.Internal.RoleMap (RoleMap)-import qualified Control.Access.RoleBased.Internal.RoleMap as RM-import           Control.Access.RoleBased.Internal.Types-import           Control.Access.RoleBased.Role----------------------------------------------------------------------------------type RoleBuilder a = StateT RoleMap RoleMonad a----------------------------------------------------------------------------------applyRule :: Role -> Rule -> [Role]-applyRule r (Rule _ f) = f r----------------------------------------------------------------------------------applyRuleSet :: Role -> RuleSet -> [Role]-applyRuleSet r (RuleSet m) = f r-  where-    f = fromMaybe (const []) $ M.lookup (_roleName r) m----------------------------------------------------------------------------------checkUnseen :: Role -> RoleBuilder ()-checkUnseen role = do-    m <- get-    if isJust $ RM.lookup role m then mzero else return ()----------------------------------------------------------------------------------checkSeen :: Role -> RoleBuilder ()-checkSeen = lnot . checkUnseen----------------------------------------------------------------------------------markSeen :: Role -> RoleBuilder ()-markSeen role = modify $ RM.insert role----------------------------------------------------------------------------------isum :: (MonadLogic m, MonadPlus m) => [m a] -> m a-isum l = case l of-            []     -> mzero-            (x:xs) -> x `interleave` isum xs------------------------------------------------------------------------------------ | Given a set of roles to check, and a set of implication rules describing--- how a given role inherits from other roles, this function produces a stream--- of expanded Roles. If a Role is seen twice, expandRoles mzeros.-expandRoles :: [Rule] -> [Role] -> RoleMonad Role-expandRoles rules roles0 = evalStateT (go roles0) RM.empty-  where-    ruleSet = rulesToSet rules--    go roles = isum $ map expandOne roles--    expandOne role = do-        checkUnseen role-        markSeen role-        return role `interleave` go newRoles--      where-        newRoles = applyRuleSet role ruleSet----------------------------------------------------------------------------------hasRole :: Role -> RuleChecker ()-hasRole r = RuleChecker $ do-    ch <- ask-    once $ go ch-  where-    go gen = do-        r' <- lift gen-        if r `matches` r' then return () else mzero----------------------------------------------------------------------------------missingRole :: Role -> RuleChecker ()-missingRole = lnot . hasRole----------------------------------------------------------------------------------hasAllRoles :: [Role] -> RuleChecker ()-hasAllRoles rs = RuleChecker $ do-    ch <- ask-    lift $ once $ go ch $ RM.fromList rs-  where-    go gen !st = do-        mr <- msplit gen-        maybe mzero-              (\(r,gen') -> let st' = RM.delete r st-                            in if RM.null st'-                                 then return ()-                                 else go gen' st')-              mr----------------------------------------------------------------------------------hasAnyRoles :: [Role] -> RuleChecker ()-hasAnyRoles rs = RuleChecker $ do-    ch <- ask-    lift $ once $ go ch-  where-    st = RM.fromList rs-    go gen = do-        mr <- msplit gen-        maybe mzero-              (\(r,gen') -> if isJust $ RM.lookup r st-                                 then return ()-                                 else go gen')-              mr----------------------------------------------------------------------------------runRuleChecker :: [Rule]-               -> [Role]-               -> RuleChecker a-               -> Bool-runRuleChecker rules roles (RuleChecker f) =-    case outs of-      []    -> False-      _     -> True-  where-    (RoleMonad st) = runReaderT f $ expandRoles rules roles-    outs = observeMany 1 st----------------------------------------------------------------------------------mkRule :: Text -> (Role -> [Role]) -> Rule-mkRule = Rule----------------------------------------------------------------------------------implies :: Role -> [Role] -> Rule-implies src dest = Rule (_roleName src)-                        (\role -> if role `matches` src then dest else [])----------------------------------------------------------------------------------impliesWith :: Role -> (HashMap Text RoleValue -> [Role]) -> Rule-impliesWith src f = Rule (_roleName src)-                         (\role -> if src `matches` role-                                     then f $ _roleData role-                                     else [])------------------------------------------------------------------------------------ Testing code follows: TODO: move into test suite---testRules :: [Rule]-testRules = [ "user" `implies` ["guest", "can_post"]-            , "superuser" `implies` [ "user"-                                    , "can_moderate"-                                    , "can_administrate"]-            , "superuser" `implies` [ addRoleData "arg" "*" "with_arg" ]-            , "with_arg" `impliesWith` \dat ->-                maybe [] (\arg -> [addRoleData "arg" arg "dependent_arg"]) $-                      M.lookup "arg" dat-            , "superuser" `implies` [ addRoleData "arg1" "a" $-                                      addRoleData "arg2" "b" "multi_args" ]-            ]--tX :: RuleChecker () -> Bool-tX f = runRuleChecker testRules ["superuser"] f--t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17 :: Bool-t1 = tX $ hasAnyRoles ["guest","userz"]--t2 = tX $ hasAllRoles ["guest","userz"]--t3 = tX $ hasAllRoles ["guest","user"]--t4 = tX $ hasRole "can_administrate"--t5 = tX $ hasRole "lkfdhjkjfhds"--t6 = tX $ do-         hasRole "guest"-         hasRole "superuser"--t7 = tX $ do-         hasRole "zzzzz"-         hasRole "superuser"--t8 = tX $ hasRole $ addRoleData "arg" "*" "dependent_arg"--t9 = tX $ hasRole "multi_args"--t10 = tX $ hasRole $ addRoleData "arg2" "b" "multi_args"--t11 = tX $ hasRole $ addRoleData "arg2" "z" "multi_args"--t12 = tX $ hasAllRoles [addRoleData "arg2" "b" "multi_args"]--t13 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"-                       , addRoleData "arg2" "b" "multi_args" ]--t14 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"-                       , addRoleData "arg2" "aaa" "multi_args" ]--t15 = tX $ missingRole "jflsdkjf"--t16 = tX $ do-          missingRole "fdjlksjlf"-          hasRole "multi_args"--t17 = tX $ missingRole "multi_args"
− src/Control/Access/RoleBased/Internal/Role.hs 
@@ -1,87 +0,0 @@-module Control.Access.RoleBased.Internal.Role where---------------------------------------------------------------------------------import           Control.Monad.ST-import           Data.Hashable-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.String-import           Data.Text (Text)-import qualified Data.Vector as V-import qualified Data.Vector.Algorithms.Merge as VA----------------------------------------------------------------------------------data RoleValue = RoleBool Bool-               | RoleText Text-               | RoleInt Int-               | RoleDouble Double-  deriving (Ord, Eq, Show)----------------------------------------------------------------------------------instance IsString RoleValue where-    fromString = RoleText . fromString----------------------------------------------------------------------------------instance Hashable RoleValue where-    hashWithSalt salt (RoleBool e)   = hashWithSalt salt e `hashWithSalt` (7 :: Int)-    hashWithSalt salt (RoleText t)   = hashWithSalt salt t `hashWithSalt` (196613 :: Int)-    hashWithSalt salt (RoleInt i)    = hashWithSalt salt i `hashWithSalt` (12582917 :: Int)-    hashWithSalt salt (RoleDouble d) =-        hashWithSalt salt d `hashWithSalt` (1610612741 :: Int)----------------------------------------------------------------------------------data Role = Role {-      _roleName :: Text-    , _roleData :: HashMap Text RoleValue-    }-  deriving (Eq, Show)----------------------------------------------------------------------------------instance IsString Role where-    fromString s = Role (fromString s) M.empty----------------------------------------------------------------------------------toSortedList :: (Ord k, Ord v) => HashMap k v -> [(k,v)]-toSortedList m = runST $ do-    v <- V.unsafeThaw $ V.fromList $ M.toList m-    VA.sort v-    v' <- V.unsafeFreeze v-    return $ V.toList v'----------------------------------------------------------------------------------instance Hashable Role where-    hashWithSalt salt (Role nm dat) =-        h $ hashWithSalt salt nm-      where-        h s = hashWithSalt s $ toSortedList dat----------------------------------------------------------------------------------data RoleValueMeta = RoleBoolMeta-                   | RoleTextMeta-                   | RoleEnumMeta [Text]-                   | RoleIntMeta-                   | RoleDoubleMeta----------------------------------------------------------------------------------data RoleDataDefinition = RoleDataDefinition {-      _roleDataName        :: Text-    , _roleValueMeta       :: RoleValueMeta-    , _roleDataDescription :: Text-    }----------------------------------------------------------------------------------data RoleMetadata = RoleMetadata {-      _roleMetadataName :: Text-    , _roleDescription  :: Text-    , _roleDataDefs     :: [RoleDataDefinition]-    }
− src/Control/Access/RoleBased/Internal/RoleMap.hs 
@@ -1,60 +0,0 @@-module Control.Access.RoleBased.Internal.RoleMap where---------------------------------------------------------------------------------import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.HashSet (HashSet)-import qualified Data.HashSet as S-import           Data.List (find, foldl')-import           Data.Text (Text)--------------------------------------------------------------------------------import           Control.Access.RoleBased.Role-import           Control.Access.RoleBased.Internal.Types----------------------------------------------------------------------------------newtype RoleMap = RoleMap (HashMap Text (HashSet Role))----------------------------------------------------------------------------------fromList :: [Role] -> RoleMap-fromList = RoleMap . foldl' ins M.empty-  where-    ins m role =-        M.insertWith S.union (_roleName role) (S.singleton role) m----------------------------------------------------------------------------------lookup :: Role -> RoleMap -> Maybe Role-lookup role (RoleMap m) = find (`matches` role) l-  where-    l = maybe [] S.toList $ M.lookup (_roleName role) m----------------------------------------------------------------------------------delete :: Role -> RoleMap -> RoleMap-delete role (RoleMap m) = RoleMap $ maybe m upd $ M.lookup rNm m-  where-    rNm = _roleName role-    upd s = maybe m-                  (\r -> let s' = S.delete r s-                         in if S.null s'-                              then M.delete rNm m-                              else M.insert rNm s' m)-                  (find (`matches` role) $ S.toList s)----------------------------------------------------------------------------------insert :: Role -> RoleMap -> RoleMap-insert role (RoleMap m) =-    RoleMap $ M.insertWith S.union (_roleName role) (S.singleton role) m----------------------------------------------------------------------------------empty :: RoleMap-empty = RoleMap M.empty----------------------------------------------------------------------------------null :: RoleMap -> Bool-null (RoleMap m) = M.null m
− src/Control/Access/RoleBased/Internal/Rule.hs 
@@ -1,37 +0,0 @@-module Control.Access.RoleBased.Internal.Rule where---------------------------------------------------------------------------------import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import           Data.List (foldl')-import           Data.Monoid-import           Data.Text (Text)--------------------------------------------------------------------------------import           Control.Access.RoleBased.Internal.Role----------------------------------------------------------------------------------data Rule = Rule Text (Role -> [Role])----------------------------------------------------------------------------------newtype RuleSet = RuleSet (HashMap Text (Role -> [Role]))----------------------------------------------------------------------------------instance Monoid RuleSet where-    mempty = RuleSet M.empty-    (RuleSet m1) `mappend` (RuleSet m2) = RuleSet $ M.foldlWithKey' ins m2 m1-      where-        combine f1 f2 r = f1 r ++ f2 r-        ins m k v       = M.insertWith combine k v m----------------------------------------------------------------------------------ruleToSet :: Rule -> RuleSet-ruleToSet (Rule nm f) = RuleSet $ M.singleton nm f----------------------------------------------------------------------------------rulesToSet :: [Rule] -> RuleSet-rulesToSet = foldl' mappend (RuleSet M.empty) . map ruleToSet
− src/Control/Access/RoleBased/Internal/Types.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}--module Control.Access.RoleBased.Internal.Types-  ( module Control.Access.RoleBased.Internal.Role-  , module Control.Access.RoleBased.Internal.Rule-  , RoleMonad(..)-  , RuleChecker(..)-  ) where---------------------------------------------------------------------------------import           Control.Applicative-import           Control.Monad.Reader-import           Control.Monad.Logic--------------------------------------------------------------------------------import           Control.Access.RoleBased.Internal.Role-import           Control.Access.RoleBased.Internal.Rule------------------------------------------------------------------------------------ TODO: should the monads be transformers here? If they were, you could check--- more complex predicates here----------------------------------------------------------------------------------newtype RoleMonad a = RoleMonad { _unRC :: Logic a }-  deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic)----------------------------------------------------------------------------------newtype RuleChecker a = RuleChecker (ReaderT (RoleMonad Role) RoleMonad a)-  deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic)-
− src/Control/Access/RoleBased/Role.hs 
@@ -1,25 +0,0 @@-module Control.Access.RoleBased.Role where---------------------------------------------------------------------------------import qualified Data.HashMap.Strict as M-import           Control.Access.RoleBased.Internal.Types-import           Data.Text (Text)----------------------------------------------------------------------------------matches :: Role -> Role -> Bool-matches (Role a1 d1) (Role a2 d2) =-    a1 == a2 && dmatch (toSortedList d1) (toSortedList d2)-  where-    dmatch []         _      = True-    dmatch _          []     = False-    dmatch dds@(d:ds) (e:es) =-        case compare d e of-          LT -> False-          EQ -> dmatch ds es-          GT -> dmatch dds es----------------------------------------------------------------------------------addRoleData :: Text -> RoleValue -> Role -> Role-addRoleData k v (Role n d) = Role n $ M.insert k v d
− src/Control/Access/RoleBased/Types.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}--module Control.Access.RoleBased.Types-  ( Role(..)                    -- fixme: remove (..)-  , RoleValue(..)               -- fixme-  , RoleValueMeta(..)-  , RoleDataDefinition(..)-  , RoleMetadata(..)-  , Rule-  , RuleChecker-  ) where--import Control.Access.RoleBased.Internal.Types
src/Snap/Snaplet.hs view
@@ -111,6 +111,7 @@   , runSnaplet   , combineConfig   , serveSnaplet+  , serveSnapletNoArgParsing   , loadAppConfig    -- * Snaplet Lenses
src/Snap/Snaplet/Auth.hs view
@@ -46,7 +46,7 @@   , Role(..)    -- * Other Utilities-  , authSettingsFromConfig +  , authSettingsFromConfig   , withBackend   , encryptPassword   , checkPassword
src/Snap/Snaplet/Auth/AuthManager.hs view
@@ -59,6 +59,7 @@   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 () @@ -81,6 +82,9 @@     , rememberCookieName    :: ByteString         -- ^ Cookie name for the remember token +    , rememberCookieDomain  :: Maybe ByteString+        -- ^ Domain for which remember cookie will be created.+     , rememberPeriod        :: Maybe Int         -- ^ Remember period in seconds. Defaults to 2 weeks. @@ -98,6 +102,6 @@     save AuthManager{..} u = save backend u     lookupByUserId AuthManager{..} u = lookupByUserId backend u     lookupByLogin AuthManager{..} u = lookupByLogin backend u+    lookupByEmail AuthManager{..}  u = lookupByEmail backend u     lookupByRememberToken AuthManager{..} u = lookupByRememberToken backend u     destroy AuthManager{..} u = destroy backend u-
src/Snap/Snaplet/Auth/Backends/JsonFile.hs view
@@ -1,31 +1,38 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeOperators        #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-} - module Snap.Snaplet.Auth.Backends.JsonFile   ( initJsonFileAuthManager   , mkJsonAuthMgr   ) where  -import           Control.Applicative+import           Control.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)+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@@ -57,6 +64,7 @@                        , activeUser            = Nothing                        , minPasswdLen          = asMinPasswdLen s                        , rememberCookieName    = asRememberCookieName s+                       , rememberCookieDomain  = Nothing                        , rememberPeriod        = asRememberPeriod s                        , siteKey               = key                        , lockout               = asLockout s@@ -85,17 +93,25 @@ ------------------------------------------------------------------------------ type UserIdCache = Map UserId AuthUser +#if !MIN_VERSION_aeson(1,0,0)+-- In aeson >= 1 these instances are not needed because we have+-- derived ToJSONKey/FromJSONKey instances for UserId. instance ToJSON UserIdCache where   toJSON m = toJSON $ HM.toList m  instance FromJSON UserIdCache where   parseJSON = fmap HM.fromList . parseJSON+#endif  ------------------------------------------------------------------------------ type LoginUserCache = Map Text UserId   ------------------------------------------------------------------------------+type EmailUserCache = Map Text UserId+++------------------------------------------------------------------------------ type RemTokenUserCache = Map Text UserId  @@ -105,6 +121,7 @@ data UserCache = UserCache {     uidCache    :: UserIdCache          -- ^ the actual datastore   , loginCache  :: LoginUserCache       -- ^ fast lookup for login field+  , emailCache  :: EmailUserCache       -- ^ fast lookup for email field   , tokenCache  :: RemTokenUserCache    -- ^ fast lookup for remember tokens   , uidCounter  :: Int                  -- ^ user id counter }@@ -115,6 +132,7 @@ defUserCache = UserCache {     uidCache   = HM.empty   , loginCache = HM.empty+  , emailCache = HM.empty   , tokenCache = HM.empty   , uidCounter = 0 }@@ -190,6 +208,8 @@             return $! cache {               uidCache   = HM.insert uid' u' $ uidCache cache             , loginCache = HM.insert (userLogin u') uid' $ loginCache cache+            , emailCache = maybe id (\em -> HM.insert em uid') (userEmail u) $+                           emailCache cache             , tokenCache = case userRememberToken u' of                              Nothing -> tokenCache cache                              Just x  -> HM.insert x uid' $ tokenCache cache@@ -208,9 +228,11 @@         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@@ -219,6 +241,16 @@                                 loginCache cache                            else loginCache cache +          let ec       = if oldEmail /= newEmail+                           then (case (oldEmail, newEmail) of+                                   (Nothing, Nothing) -> id+                                   (Just e,  Nothing) -> HM.delete e+                                   (Nothing, Just e ) -> HM.insert e uid+                                   (Just e,  Just e') -> HM.insert e' uid .+                                                         HM.delete e+                                ) (emailCache cache)+                           else emailCache cache+           let tc       = if oldToken /= newToken && isJust oldToken                            then HM.delete (fromJust oldToken) $ loginCache cache                            else tokenCache cache@@ -232,6 +264,7 @@           let new      = cache {                              uidCache   = HM.insert uid u' $ uidCache cache                            , loginCache = lc+                           , emailCache = ec                            , tokenCache = tc'                          } @@ -265,6 +298,16 @@       f cache = getUid >>= getUser cache         where getUid = HM.lookup login (loginCache cache) +  lookupByEmail mgr email = withCache mgr f+    where+      f cache = getEmail >>= getUser cache+        where getEmail = case HM.lookup email (emailCache cache) of+                      Just u  -> return u+                      Nothing -> (join . fmap userId .+                                  listToMaybe . HM.elems $+                                  HM.filter ((== Just email) . userEmail)+                                  (uidCache  cache))+   lookupByRememberToken mgr token = withCache mgr f     where       f cache = getUid >>= getUser cache@@ -298,6 +341,7 @@   toJSON uc = object     [ "uidCache"   .= uidCache   uc     , "loginCache" .= loginCache uc+    , "emailCache" .= emailCache uc     , "tokenCache" .= tokenCache uc     , "uidCounter" .= uidCounter uc     ]@@ -309,8 +353,8 @@     UserCache       <$> v .: "uidCache"       <*> v .: "loginCache"+      <*> (v .: "emailCache" <|> pure mempty) -- Old versions of users.json do+                                              -- not carry this field       <*> v .: "tokenCache"       <*> v .: "uidCounter"   parseJSON _ = error "Unexpected JSON input"--
src/Snap/Snaplet/Auth/Handlers.hs view
@@ -11,8 +11,8 @@  ------------------------------------------------------------------------------ import           Control.Applicative+import           Control.Monad (join, liftM, liftM2) import           Control.Monad.State-import           Control.Monad.Trans.Either import           Control.Monad.Trans.Maybe import           Data.ByteString (ByteString) import           Data.Maybe@@ -26,7 +26,6 @@ import           Snap.Core import           Snap.Snaplet import           Snap.Snaplet.Auth.AuthManager-import           Snap.Snaplet.Auth.Handlers.Errors import           Snap.Snaplet.Auth.Types import           Snap.Snaplet.Session ------------------------------------------------------------------------------@@ -70,18 +69,20 @@ loginByUsername unm pwd shouldRemember = do     sk <- gets siteKey     cn <- gets rememberCookieName+    cd <- gets rememberCookieDomain     rp <- gets rememberPeriod-    withBackend $ loginByUsername' sk cn rp+    withBackend $ loginByUsername' sk cn cd rp    where     --------------------------------------------------------------------------     loginByUsername' :: (IAuthBackend t) =>                         Key                      -> ByteString+                     -> Maybe ByteString                      -> Maybe Int                      -> t                      -> Handler b (AuthManager b) (Either AuthFailure AuthUser)-    loginByUsername' sk cn rp r =+    loginByUsername' sk cn cd rp r =         liftIO (lookupByLogin r unm) >>=         maybe (return $! Left UserNotFound) found @@ -96,7 +97,7 @@                   token <- gets randomNumberGenerator >>=                            liftIO . randomToken 64 -                  setRememberToken sk cn rp token+                  setRememberToken sk cn cd rp token                    let user' = user {                                 userRememberToken = Just (decodeUtf8 token)@@ -117,14 +118,15 @@     cookieName_ <- gets rememberCookieName     period      <- gets rememberPeriod -    runEitherT $ do-        token <- noteT (AuthError "loginByRememberToken: no remember token") $-                   MaybeT $ getRememberToken key cookieName_ period-        user  <- noteT (AuthError "loginByRememberToken: no remember token") $-                   MaybeT $ liftIO $ lookupByRememberToken impl-                                   $ decodeUtf8 token-        lift $ forceLogin user-        return user+    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   ------------------------------------------------------------------------------@@ -135,7 +137,8 @@     s <- gets session     withTop s $ withSession s removeSessionUserId     rc <- gets rememberCookieName-    forgetRememberToken rc+    rd <- gets rememberCookieDomain+    expireSecureCookie rc rd     modify $ \mgr -> mgr { activeUser = Nothing }  @@ -147,7 +150,7 @@     s   <- gets session     uid <- withTop s getSessionUserId     case uid of-      Nothing -> hush <$> loginByRememberToken+      Nothing -> either (const Nothing) Just <$> loginByRememberToken       Just uid' -> liftIO $ lookupByUserId r uid'  @@ -227,7 +230,7 @@      --------------------------------------------------------------------------     updateIp u' = do-        ip <- rqRemoteAddr <$> getRequest+        ip <- rqClientAddr <$> getRequest         return $ u' { userLastLoginIp = userCurrentLoginIp u'                     , userCurrentLoginIp = Just ip } @@ -322,15 +325,11 @@ setRememberToken :: (Serialize t, MonadSnap m)                  => Key                  -> ByteString+                 -> Maybe ByteString                  -> Maybe Int                  -> t                  -> m ()-setRememberToken sk rc rp token = setSecureCookie rc sk rp token----------------------------------------------------------------------------------forgetRememberToken :: MonadSnap m => ByteString -> m ()-forgetRememberToken rc = expireCookie rc (Just "/")+setRememberToken sk rc rd rp token = setSecureCookie rc rd sk rp token   ------------------------------------------------------------------------------@@ -401,8 +400,8 @@     l <- fmap decodeUtf8 <$> getParam lf     p <- getParam pf -    let l' = note UsernameMissing l-    let p' = note PasswordMissing p+    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.@@ -434,29 +433,28 @@       -- ^ Upon success   -> Handler b (AuthManager b) () loginUser unf pwdf remf loginFail loginSucc =-    runEitherT (loginUser' unf pwdf remf)-    >>= either loginFail (const loginSucc)+    loginUser' unf pwdf remf >>= either loginFail (const loginSucc)   ------------------------------------------------------------------------------ loginUser' :: ByteString            -> ByteString            -> Maybe ByteString-           -> EitherT AuthFailure (Handler b (AuthManager b)) AuthUser+           -> Handler b (AuthManager b) (Either AuthFailure AuthUser) loginUser' unf pwdf remf = do-    mbUsername <- lift $ getParam unf-    mbPassword <- lift $ getParam pwdf-    remember   <- lift $ liftM (fromMaybe False)+    mbUsername <- getParam unf+    mbPassword <- getParam pwdf+    remember   <- liftM (fromMaybe False)                     (runMaybeT $                     do field <- MaybeT $ return remf                        value <- MaybeT $ getParam field                        return $ value == "1" || value == "on") -    password <- noteT PasswordMissing $ hoistMaybe mbPassword-    username <- noteT UsernameMissing $ hoistMaybe mbUsername--    EitherT $ loginByUsername (decodeUtf8 username)-                              (ClearText password) remember+    case mbUsername of+      Nothing -> return $ Left UsernameMissing+      Just u -> case mbPassword of+        Nothing -> return $ Left PasswordMissing+        Just p -> loginByUsername (decodeUtf8 u) (ClearText p) remember   ------------------------------------------------------------------------------@@ -500,7 +498,7 @@       -- ^ The function to run with the handler.   -> Handler b (AuthManager v) a withBackend f = join $ do-  (AuthManager backend_ _ _ _ _ _ _ _ _) <- get+  (AuthManager backend_ _ _ _ _ _ _ _ _ _) <- get   return $ f backend_  
− src/Snap/Snaplet/Auth/Handlers/Errors.hs 
@@ -1,33 +0,0 @@--- | An internal module that copies a few select functions--- from Control.Error.Util, as used in Snap.Snaplet.Auth.Handlers.-module Snap.Snaplet.Auth.Handlers.Errors-  ( hush-  , hushT-  , note-  , noteT-  , hoistMaybe-  ) where--import Control.Monad-import Control.Monad.Trans.Either-import Control.Monad.Trans.Maybe---- | Suppress the 'Left' value of an 'Either'-hush :: Either a b -> Maybe b-hush = either (const Nothing) Just---- | Suppress the 'Left' value of an 'EitherT'-hushT :: (Monad m) => EitherT a m b -> MaybeT m b-hushT = MaybeT . liftM hush . runEitherT---- | Tag the 'Nothing' value of a 'Maybe'-note :: a -> Maybe b -> Either a b-note a = maybe (Left a) Right---- | Tag the 'Nothing' value of a 'MaybeT'-noteT :: (Monad m) => a -> MaybeT m b -> EitherT a m b-noteT a = EitherT . liftM (note a) . runMaybeT---- | Lift a 'Maybe' to the 'MaybeT' monad-hoistMaybe :: (Monad m) => Maybe b -> MaybeT m b-hoistMaybe = MaybeT . return
src/Snap/Snaplet/Auth/SpliceHelpers.hs view
@@ -1,8 +1,9 @@+{-# LANGUAGE CPP                       #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}  {-| @@ -27,8 +28,8 @@ ------------------------------------------------------------------------------ import           Control.Lens import           Control.Monad.Trans+import           Data.Map.Syntax ((##), mapV) import           Data.Maybe-import           Data.Monoid import qualified Data.Text as T import           Data.Text.Encoding import qualified Text.XmlHtml as X@@ -41,6 +42,11 @@ 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+ ------------------------------------------------------------------------------  @@ -66,9 +72,9 @@         "ifLoggedOut"  ## ifLoggedOut auth         "loggedInUser" ## loggedInUser auth     cs = compiledAuthSplices auth-      + ------------------------------------------------------------------------------ -- | List containing compiled splices for ifLoggedIn, ifLoggedOut, and -- loggedInUser.@@ -183,7 +189,7 @@ loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b loggedInUser auth = do     u <- lift $ withTop auth currentUser-    maybe (return []) (I.textSplice . userLogin) u +    maybe (return []) (I.textSplice . userLogin) u   -------------------------------------------------------------------------------@@ -193,6 +199,4 @@ cLoggedInUser auth =     return $ C.yieldRuntimeText $ do         u <- lift $ withTop auth currentUser-        return $ maybe "" userLogin u --+        return $ maybe "" userLogin u
src/Snap/Snaplet/Auth/Types.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE ExistentialQuantification  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE StandaloneDeriving         #-}  module Snap.Snaplet.Auth.Types where  -------------------------------------------------------------------------------import           Control.Applicative import           Control.Arrow import           Control.Monad.Trans import           Crypto.PasswordStore@@ -18,11 +19,15 @@ import           Data.Hashable         (Hashable) import           Data.Time import           Data.Text             (Text)-import           Data.Text.Encoding+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.@@ -109,6 +114,10 @@ newtype UserId = UserId { unUid :: Text }   deriving ( Read, Show, Ord, Eq, FromJSON, ToJSON, Hashable ) +#if MIN_VERSION_aeson(1,0,0)+deriving instance FromJSONKey UserId+deriving instance ToJSONKey UserId+#endif  ------------------------------------------------------------------------------ -- | This will be replaced by a role-based permission system.
src/Snap/Snaplet/Config.hs view
@@ -1,22 +1,44 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE DeriveDataTypeable #-}  module Snap.Snaplet.Config where -import Data.Function-import Data.Maybe-import Data.Monoid-import Data.Typeable+------------------------------------------------------------------------------+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-import System.Console.GetOpt+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+  deriving Typeable #else  ------------------------------------------------------------------------------@@ -33,17 +55,23 @@     typeOf _ = mkTyConApp appConfigTyCon [] #endif --------------------------------------------------------------------------------instance Monoid AppConfig where-    mempty = AppConfig Nothing-    mappend a b = AppConfig+instance Semigroup AppConfig where+    a <> b = AppConfig         { appEnvironment = ov appEnvironment a b         }       where-        ov f x y = getLast $! (mappend `on` (Last . f)) x y+        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))@@ -67,4 +95,3 @@                               mappend defaults   where     appDefaults = fromMaybe mempty $ getOther defaults-
src/Snap/Snaplet/Heist/Internal.hs view
@@ -3,8 +3,10 @@  import           Prelude import           Control.Lens+import           Control.Monad (liftM) import           Control.Monad.State-import           Control.Monad.Trans.Either+import qualified Data.ByteString as B+import           Data.Char import qualified Data.HashMap.Strict as Map import           Data.IORef import           Data.List@@ -69,7 +71,7 @@ heistInitWorker templateDir initialConfig = do     snapletPath <- getSnapletFilePath     let tDir = snapletPath </> templateDir-    templates <- liftIO $ runEitherT (loadTemplates tDir) >>=+    templates <- liftIO $ (loadTemplates tDir) >>=                           either (error . concat) return     printInfo $ T.pack $ unwords         [ "...loaded"@@ -77,29 +79,42 @@         , "templates from"         , tDir         ]-    let config = over hcTemplateLocations (<> [loadTemplates tDir])-                      initialConfig+    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 -> EitherT Text IO (Heist b)+finalLoadHook :: Heist b -> IO (Either Text (Heist b)) finalLoadHook (Configuring ref) = do-    (hc,dm) <- lift $ readIORef ref-    (hs,cts) <- toTextErrors $ initHeistWithCacheTag hc-    return $ Running hc hs cts dm+    (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 = bimapEitherT (T.pack . intercalate "\n") id-finalLoadHook (Running _ _ _ _) = left "finalLoadHook called while running"+    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@@ -109,10 +124,8 @@ heistReloader :: Handler b (Heist b) () heistReloader = do     h <- get-    ehs <- liftIO $ runEitherT $ initHeist $ _masterConfig h+    ehs <- liftIO $ initHeist $ _masterConfig h     either (writeText . T.pack . unlines)            (\hs -> do writeText "Heist reloaded."                       modifyMaster $ set heistState hs h)            ehs--
src/Snap/Snaplet/HeistNoClass.hs view
@@ -21,7 +21,7 @@   , heistInit'   , heistReloader   , setInterpreted-  , getCurHeistConfig +  , getCurHeistConfig   , clearHeistCache    , addTemplates@@ -66,14 +66,12 @@ import           Control.Lens import           Control.Monad.Reader import           Control.Monad.State-import           Control.Monad.Trans.Either import           Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import           Data.DList (DList) import qualified Data.HashMap.Strict as Map import           Data.IORef import           Data.Maybe-import           Data.Monoid import qualified Data.Text as T import           Data.Text.Encoding import           System.FilePath.Posix@@ -82,6 +80,10 @@ 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@@ -159,7 +161,7 @@ -- 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 = +setInterpreted h =     liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h)         (\(hc,_) -> ((hc,Interpreted),())) @@ -196,7 +198,7 @@                      (T.unpack $ decodeUtf8 urlPrefix)         addPrefix = addTemplatePathPrefix                       (encodeUtf8 $ T.pack fullPrefix)-    ts <- liftIO $ runEitherT (loadTemplates templateDir) >>=+    ts <- liftIO $ (loadTemplates templateDir) >>=                    either (error . concat) return     printInfo $ T.pack $ unwords         [ "...adding"@@ -206,7 +208,7 @@         , "with route prefix"         , fullPrefix ++ "/"         ]-    let locations = [liftM addPrefix $ loadTemplates templateDir]+    let locations = [fmap addPrefix <$> loadTemplates templateDir]         add (hc, dm) =           ((over hcTemplateLocations (mappend locations) hc, dm), ())     liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) add@@ -220,8 +222,8 @@         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))@@ -233,7 +235,7 @@                   -> (HeistState (Handler b b) -> HeistState (Handler b b))                   -> Initializer b v () modifyHeistState' heist f = do-    withTop' heist $ addPostInitHook $ return . changeState f+    withTop' heist $ addPostInitHook $ return . Right . changeState f   ------------------------------------------------------------------------------@@ -478,5 +480,3 @@                   -> Handler b v () renderWithSplices heist t splices =     renderWithSplices' (subSnaplet heist) t splices--
src/Snap/Snaplet/Internal/Initializer.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}  module Snap.Snaplet.Internal.Initializer   ( addPostInitHook@@ -19,6 +19,7 @@   , runSnaplet   , combineConfig   , serveSnaplet+  , serveSnapletNoArgParsing   , loadAppConfig   , printInfo   , getRoutes@@ -26,36 +27,57 @@   , modifyMaster   ) where -import           Prelude hiding (catch)-import           Control.Concurrent.MVar-import           Control.Exception (SomeException)-import           Control.Lens-import           Control.Monad-import           Control.Monad.CatchIO hiding (Handler)-import           Control.Monad.Reader-import           Control.Monad.State-import           Control.Monad.Trans.Either-import           Control.Monad.Trans.Writer hiding (pass)-import           Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B-import           Data.Configurator-import qualified Data.Configurator.Types as C-import           Data.IORef-import           Data.Maybe-import           Data.Text (Text)-import qualified Data.Text as T-import           Snap.Http.Server-import           Snap.Core-import           Snap.Util.GZip-import           System.Directory-import           System.Directory.Tree-import           System.FilePath.Posix-import           System.IO--import           Snap.Snaplet.Config-import qualified Snap.Snaplet.Internal.LensT as LT+------------------------------------------------------------------------------+import           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+------------------------------------------------------------------------------   ------------------------------------------------------------------------------@@ -89,18 +111,18 @@ ------------------------------------------------------------------------------ -- | Return the current environment string.  This will be the -- environment given to 'runSnaplet' or from the command line when--- using 'serveSnaplet'.  Usefully for changing behavior during+-- 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 -> EitherT Text IO v)-              -> (Snaplet v -> EitherT Text IO (Snaplet v))+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'+    return $! Snaplet cfg reset <$> val'   ------------------------------------------------------------------------------@@ -111,12 +133,12 @@ -- define its views.  The Heist snaplet provides the 'addTemplates' function -- which allows other snaplets to set up their own templates.  'addTemplates' -- is implemented using this function.-addPostInitHook :: (v -> EitherT Text IO v)+addPostInitHook :: (v -> IO (Either Text v))                 -> Initializer b v () addPostInitHook = addPostInitHook' . toSnapletHook  -addPostInitHook' :: (Snaplet v -> EitherT Text IO (Snaplet v))+addPostInitHook' :: (Snaplet v -> IO (Either Text (Snaplet v)))                  -> Initializer b v () addPostInitHook' h = do     h' <- upHook h@@ -125,15 +147,15 @@  ------------------------------------------------------------------------------ -- | Variant of addPostInitHook for when you have things wrapped in a Snaplet.-addPostInitHookBase :: (Snaplet b -> EitherT Text IO (Snaplet b))+addPostInitHookBase :: (Snaplet b -> IO (Either Text (Snaplet b)))                     -> Initializer b v () addPostInitHookBase = Initializer . lift . tell . Hook   ------------------------------------------------------------------------------ -- | Helper function for transforming hooks.-upHook :: (Snaplet v -> EitherT Text IO (Snaplet v))-       -> Initializer b v (Snaplet b -> EitherT Text IO (Snaplet b))+upHook :: (Snaplet v -> IO (Either Text (Snaplet v)))+       -> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b))) upHook h = Initializer $ do     l <- ask     return $ upHook' l h@@ -141,10 +163,12 @@  ------------------------------------------------------------------------------ -- | Helper function for transforming hooks.-upHook' :: Monad m => ALens' b a -> (a -> m a) -> b -> m b+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 $ storing l v b+    return $ case v of+               Left e -> Left e+               Right v' -> Right $ storing l v' b   ------------------------------------------------------------------------------@@ -256,9 +280,9 @@     l <- getLens     let modifier = setInTop  . set (cloneLens l . snapletValue)     return $ Snaplet cfg modifier res-      + ------------------------------------------------------------------------------ -- | Brackets an initializer computation, restoring curConfig after the -- computation returns.@@ -493,7 +517,7 @@   --------------------------------------------------------------------------------- | Lets you change a snaplet's initial state.  It's alomst like a reload,+-- | 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.@@ -530,12 +554,12 @@     let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing reloader_     logRef <- newIORef "" -    let body = runEitherT $ do-            ((res, s), (Hook hook)) <- lift $ runWriterT $ LT.runLensT i id $+    let body = do+            ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $                 InitializerState True cleanupRef builtinHandlers id cfg logRef                                  env resetter             res' <- hook res-            right (res', s)+            return $ (,s) <$> res'          handler e = do             join $ readIORef cleanupRef@@ -565,11 +589,11 @@     let resetter f = modifyMVar_ snapletMVar (return . f)     eRes <- runInitializer resetter (fromMaybe "devel" env) b     let go (siteSnaplet,is) = do-        putMVar snapletMVar siteSnaplet-        msgs <- liftIO $ readIORef $ _initMessages is-        let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar-        cleanupAction <- readIORef $ _cleanup is-        return (msgs, handler, cleanupAction)+            putMVar snapletMVar siteSnaplet+            msgs <- liftIO $ readIORef $ _initMessages is+            let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar+            cleanupAction <- readIORef $ _cleanup is+            return (msgs, handler, cleanupAction)     either (error . ('\n':) . T.unpack) go eRes  @@ -601,13 +625,25 @@                  -- ^ The snaplet initializer function.              -> IO () serveSnaplet startConfig initializer = do-    config       <- commandLineAppConfig startConfig+    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 = simpleHttpServe conf+    let serve = httpServe conf      when (loggingEnabled conf) $ liftIO $ hPutStrLn stderr $ T.unpack msgs     _ <- try $ serve $ site@@ -665,5 +701,5 @@ getCfg cfg (Dir _ c) = map file $ filter (isCfg cfg) c getCfg _ _ = [] -    + 
src/Snap/Snaplet/Internal/LensT.hs view
@@ -2,19 +2,32 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}  module Snap.Snaplet.Internal.LensT where -import           Control.Applicative-import           Control.Category-import           Control.Lens-import           Control.Monad.CatchIO-import           Control.Monad.Reader-import           Control.Monad.State.Class-import           Prelude hiding ((.), id, catch)-import           Snap.Core -import           Snap.Snaplet.Internal.RST+------------------------------------------------------------------------------+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)@@ -24,16 +37,38 @@            , Applicative            , MonadIO            , MonadPlus-           , MonadCatchIO            , Alternative-           , MonadReader (ALens' b v)-           , MonadSnap )+           , 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   ------------------------------------------------------------------------------
src/Snap/Snaplet/Internal/Lensed.hs view
@@ -1,22 +1,34 @@ {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}  module Snap.Snaplet.Internal.Lensed where -import Control.Applicative-import Control.Lens-import Control.Monad-import Control.Monad.Reader.Class-import Control.Monad.Trans-import Control.Monad.CatchIO-import Control.Monad.State.Class-import Control.Monad.State.Strict-import Control.Category-import Prelude hiding (catch, id, (.))-import Snap.Core  ------------------------------------------------------------------------------+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) } @@ -36,6 +48,11 @@   ------------------------------------------------------------------------------+instance Fail.MonadFail m => Fail.MonadFail (Lensed b v m) where+    fail s = Lensed $ \_ _ _ -> Fail.fail s+++------------------------------------------------------------------------------ instance Monad m => Monad (Lensed b v m) where     return a = Lensed $ \_ v s -> return (a, v, s)     Lensed g >>= k = Lensed $ \l v s -> do@@ -71,17 +88,6 @@   -------------------------------------------------------------------------------instance MonadCatchIO m => MonadCatchIO (Lensed b v m) where-    catch (Lensed m) f = Lensed $ \l v b -> m l v b `catch` handler l v b-      where-        handler l v b e = let Lensed h = f e-                          in h l v b--    block (Lensed m)   = Lensed $ \l v b -> block (m l v b)-    unblock (Lensed m) = Lensed $ \l v b -> unblock (m l v b)--------------------------------------------------------------------------------- instance MonadPlus m => MonadPlus (Lensed b v m) where     mzero = lift mzero     m `mplus` n = Lensed $ \l v b ->@@ -97,6 +103,31 @@ ------------------------------------------------------------------------------ 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 #-}   ------------------------------------------------------------------------------
src/Snap/Snaplet/Internal/RST.hs view
@@ -1,16 +1,24 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}  module Snap.Snaplet.Internal.RST where -import           Control.Applicative-import           Control.Category-import           Control.Monad.CatchIO-import           Control.Monad.Reader-import           Control.Monad.State.Class-import           Prelude hiding ((.), id, catch)-import           Snap.Core+import           Control.Applicative         (Alternative (..),+                                              Applicative (..))+import           Control.Monad+import           Control.Monad.Base          (MonadBase (..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Reader        (MonadReader (..))+import           Control.Monad.State.Class   (MonadState (..))+import           Control.Monad.Trans         (MonadIO (..), MonadTrans (..))+import           Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),+                                              MonadTransControl (..),+                                              defaultLiftBaseWith,+                                              defaultRestoreM)+import           Snap.Core                   (MonadSnap (..))   ------------------------------------------------------------------------------@@ -66,12 +74,6 @@ mapRST f m = RST $ \r s -> f (runRST m r s)  -instance (MonadCatchIO m) => MonadCatchIO (RST r s m) where-    m `catch` f = RST $ \r s -> runRST m r s-                           `catch` \e -> runRST (f e) r s-    block       = mapRST block-    unblock     = mapRST unblock- instance (MonadSnap m) => MonadSnap (RST r s m) where     liftSnap s = lift $ liftSnap s @@ -89,21 +91,45 @@ instance (Monad m) => Monad (RST r s m) where     return a = RST $ \_ s -> return (a, s)     (>>=)    = rwsBind+#if !MIN_VERSION_base(4,13,0)     fail msg = RST $ \_ _ -> fail msg+#endif +instance Fail.MonadFail m => Fail.MonadFail (RST r s m) where+    fail msg = RST $ \_ _ -> Fail.fail msg  instance (MonadPlus m) => MonadPlus (RST r s m) where     mzero       = RST $ \_ _ -> mzero     m `mplus` n = RST $ \r s -> runRST m r s `mplus` runRST n r s  +instance (MonadIO m) => MonadIO (RST r s m) where+    liftIO = lift . liftIO++ instance MonadTrans (RST r s) where     lift m = RST $ \_ s -> do         a <- m         return $ s `seq` (a, s) -instance (MonadIO m) => MonadIO (RST r s m) where-    liftIO = lift . liftIO +instance MonadBase b m => MonadBase b (RST r s m) where+    liftBase = lift . liftBase  +instance MonadBaseControl b m => MonadBaseControl b (RST r s m) where+     type StM (RST r s m) a = ComposeSt (RST r s) m a+     liftBaseWith = defaultLiftBaseWith+     restoreM = defaultRestoreM+     {-# INLINE liftBaseWith #-}+     {-# INLINE restoreM #-}+++instance MonadTransControl (RST r s) where+    type StT (RST r s) a = (a, s)+    liftWith f = RST $ \r s -> do+        res <- f $ \(RST g) -> g r s+        return (res, s)+    restoreT k = RST $ \_ _ -> k+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}
src/Snap/Snaplet/Internal/Types.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE CPP                        #-} {-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImpredicativeTypes         #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE TypeFamilies               #-}  #ifndef MIN_VERSION_comonad #define MIN_VERSION_comonad(x,y,z) 1@@ -13,26 +15,38 @@  module Snap.Snaplet.Internal.Types where -import           Control.Applicative-import           Control.Lens-import           Control.Monad.CatchIO hiding (Handler)-import           Control.Monad.Reader-import           Control.Monad.State.Class-import           Control.Monad.Trans.Either-import           Control.Monad.Trans.Writer hiding (pass)-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import           Data.Configurator.Types-import           Data.IORef-import           Data.Monoid-import           Data.Text (Text)+------------------------------------------------------------------------------+import           Control.Applicative          (Alternative)+import           Control.Lens                 (ALens', makeLenses, set)+import           Control.Monad                (MonadPlus, liftM)+import           Control.Monad.Base           (MonadBase (..))+import           Control.Monad.Fail           (MonadFail)+import           Control.Monad.Reader         (MonadIO (..), MonadReader (ask, local))+import           Control.Monad.State.Class    (MonadState (get, put), gets)+import           Control.Monad.Trans.Control  (MonadBaseControl (..))+import           Control.Monad.Trans.Writer   (WriterT)+import           Data.ByteString              (ByteString)+import qualified Data.ByteString.Char8        as B (dropWhile, intercalate, null, reverse)+import           Data.Configurator.Types      (Config)+import           Data.IORef                   (IORef)+import           Data.Text                    (Text)+import           Snap.Core                    (MonadSnap, Request (rqClientAddr), Snap, bracketSnap, getRequest, pass, writeText)+import qualified Snap.Snaplet.Internal.Lensed as L (Lensed (..), runLensed, with, withTop)+import qualified Snap.Snaplet.Internal.LensT  as LT (LensT, getBase, with, withTop) -import           Snap.Core-import qualified Snap.Snaplet.Internal.LensT as LT-import qualified Snap.Snaplet.Internal.Lensed as L+#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative          (Applicative)+import           Data.Monoid                  (Monoid (mappend, mempty))+#endif +#if !MIN_VERSION_base(4,11,0)+import           Data.Semigroup               (Semigroup(..))+#endif  ------------------------------------------------------------------------------+++------------------------------------------------------------------------------ -- | An opaque data type holding internal snaplet configuration data.  It is -- exported publicly because the getOpaqueConfig function in MonadSnaplet -- makes implementing new instances of MonadSnaplet more convenient.@@ -121,8 +135,17 @@ 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.@@ -251,18 +274,39 @@ -- 'MonadSnaplet' instance, which gives you all the functionality described -- above. newtype Handler b v a =-    Handler (L.Lensed (Snaplet b) (Snaplet v) Snap a)+    Handler { _unHandler :: L.Lensed (Snaplet b) (Snaplet v) Snap a }   deriving ( Monad            , Functor            , Applicative+           , MonadFail            , MonadIO            , MonadPlus-           , MonadCatchIO            , Alternative            , MonadSnap)   ------------------------------------------------------------------------------+instance MonadBase IO (Handler b v) where+    liftBase = liftIO+++------------------------------------------------------------------------------+newtype StMHandler b v a = StMHandler {+      unStMHandler :: StM (L.Lensed (Snaplet b) (Snaplet v) Snap) a+    }+++instance MonadBaseControl IO (Handler b v) where+    type StM (Handler b v) a = StMHandler b v a+    liftBaseWith f = Handler+                       $ liftBaseWith+                       $ \g' -> f+                       $ \m -> liftM StMHandler+                       $ g' $ _unHandler m+    restoreM = Handler . restoreM . unStMHandler+++------------------------------------------------------------------------------ -- | Gets the @Snaplet v@ from the current snaplet's state. getSnapletState :: Handler b v (Snaplet v) getSnapletState = Handler get@@ -292,14 +336,16 @@   --------------------------------------------------------------------------------- | The MonadState instance gives you access to the current snaplet's state.+-- | Lets you access the current snaplet's state through the 'MonadState'+-- interface. instance MonadState v (Handler b v) where     get = getsSnapletState _snapletValue     put v = modifySnapletState (set snapletValue v)   --------------------------------------------------------------------------------- | The MonadState instance gives you access to the current snaplet's state.+-- | 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@@ -310,6 +356,7 @@         return res  +------------------------------------------------------------------------------ instance MonadSnaplet Handler where     getLens = Handler ask     with' !l (Handler !m) = Handler $ L.with l m@@ -343,16 +390,21 @@   ------------------------------------------------------------------------------+-- | 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-    -- FIXME: this moves to auth once control-panel is done-    rip <- liftM rqRemoteAddr getRequest-    if not $ elem rip [ "127.0.0.1"-                      , "localhost"-                      , "::1" ]-      then pass-      else m+    isLocal <- isLocalhost+    if isLocal then m else pass   ------------------------------------------------------------------------------@@ -419,12 +471,26 @@ ------------------------------------------------------------------------------ -- | Wrapper around IO actions that modify state elements created during -- initialization.-newtype Hook a = Hook (Snaplet a -> EitherT Text IO (Snaplet a))+newtype Hook a = Hook (Snaplet a -> IO (Either Text (Snaplet a))) +instance Semigroup (Hook a) where+    Hook a <> Hook b = Hook $ \s -> do+      ea <- a s+      case ea of+        Left e -> return $ Left e+        Right ares -> do+          eb <- b ares+          case eb of+            Left e -> return $ Left e+            Right bres -> return $ Right bres ++------------------------------------------------------------------------------ instance Monoid (Hook a) where-    mempty = Hook return-    (Hook a) `mappend` (Hook b) = Hook (a >=> b)+    mempty = Hook (return . Right)+#if !MIN_VERSION_base(4,11,0)+    mappend = (<>)+#endif   ------------------------------------------------------------------------------@@ -440,6 +506,7 @@ makeLenses ''InitializerState  +------------------------------------------------------------------------------ instance MonadSnaplet Initializer where     getLens = Initializer ask     with' !l (Initializer !m) = Initializer $ LT.with l m@@ -451,5 +518,3 @@ -- | Opaque newtype which gives us compile-time guarantees that the user is -- using makeSnaplet and either nestSnaplet or embedSnaplet correctly. newtype SnapletInit b v = SnapletInit (Initializer b v (Snaplet v))--
src/Snap/Snaplet/Session/Backends/CookieSession.hs view
@@ -1,4 +1,5 @@ ------------------------------------------------------------------------------+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-}@@ -8,18 +9,21 @@     ) where  -------------------------------------------------------------------------------import           Control.Applicative 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           Data.Typeable 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@@ -78,6 +82,10 @@         -- ^ A long encryption key used for secure cookie transport     , cookieName            :: ByteString         -- ^ Cookie name for the session system+    , cookieDomain          :: Maybe ByteString+        -- ^ Cookie domain for session system. You may want to set it to+        -- dot prefixed domain name like ".example.com", so the cookie is+        -- available to sub domains.     , timeOut               :: Maybe Int         -- ^ Session cookies will be considered "stale" after this many         -- seconds.@@ -88,7 +96,7 @@  ------------------------------------------------------------------------------ loadDefSession :: CookieSessionManager -> IO CookieSessionManager-loadDefSession mgr@(CookieSessionManager ses _ _ _ rng) =+loadDefSession mgr@(CookieSessionManager ses _ _ _ _ rng) =     case ses of       Nothing -> do ses' <- mkCookieSession rng                     return $! mgr { session = Just ses' }@@ -109,22 +117,23 @@ initCookieSessionManager     :: FilePath             -- ^ Path to site-wide encryption key     -> ByteString           -- ^ Session cookie name+    -> Maybe ByteString     -- ^ Session cookie domain     -> Maybe Int            -- ^ Session time-out (replay attack protection)     -> SnapletInit b SessionManager-initCookieSessionManager fp cn to =+initCookieSessionManager fp cn dom to =     makeSnaplet "CookieSession"                 "A snaplet providing sessions via HTTP cookies."                 Nothing $ liftIO $ do         key <- getKey fp         rng <- liftIO mkRNG-        return $! SessionManager $ CookieSessionManager Nothing key cn to rng+        return $! SessionManager $ CookieSessionManager Nothing key cn dom to rng   ------------------------------------------------------------------------------ instance ISessionManager CookieSessionManager where      ---------------------------------------------------------------------------    load mgr@(CookieSessionManager r _ _ _ _) =+    load mgr@(CookieSessionManager r _ _ _ _ _) =         case r of           Just _ -> return mgr           Nothing -> do@@ -138,7 +147,7 @@                   Right cs -> return $ mgr { session = Just cs }      ---------------------------------------------------------------------------    commit mgr@(CookieSessionManager r _ _ _ rng) = do+    commit mgr@(CookieSessionManager r _ _ _ _ rng) = do         pl <- case r of                 Just r' -> return . Payload $ S.encode r'                 Nothing -> liftIO (mkCookieSession rng) >>=@@ -154,25 +163,25 @@     touch = id      ---------------------------------------------------------------------------    insert k v mgr@(CookieSessionManager r _ _ _ _) = case r of+    insert k v mgr@(CookieSessionManager r _ _ _ _ _) = case r of         Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }         Nothing -> mgr      ---------------------------------------------------------------------------    lookup k (CookieSessionManager r _ _ _ _) = r >>= HM.lookup k . csSession+    lookup k (CookieSessionManager r _ _ _ _ _) = r >>= HM.lookup k . csSession      ---------------------------------------------------------------------------    delete k mgr@(CookieSessionManager r _ _ _ _) = case r of+    delete k mgr@(CookieSessionManager r _ _ _ _ _) = case r of         Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }         Nothing -> mgr      ---------------------------------------------------------------------------    csrf (CookieSessionManager r _ _ _ _) = case r of+    csrf (CookieSessionManager r _ _ _ _ _) = case r of         Just r' -> csCSRFToken r'         Nothing -> ""      ---------------------------------------------------------------------------    toList (CookieSessionManager r _ _ _ _) = case r of+    toList (CookieSessionManager r _ _ _ _ _) = case r of         Just r' -> HM.toList . csSession $ r'         Nothing -> [] @@ -192,5 +201,5 @@ ------------------------------------------------------------------------------ -- | Set the client-side value setPayload :: CookieSessionManager -> Payload -> Snap ()-setPayload mgr x = setSecureCookie (cookieName mgr) (siteKey mgr)-                                   (timeOut mgr) x+setPayload mgr x = setSecureCookie (cookieName mgr) (cookieDomain mgr)+                                   (siteKey mgr) (timeOut mgr) x
src/Snap/Snaplet/Session/Common.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP               #-} ------------------------------------------------------------------------------ -- | This module contains functionality common among multiple back-ends. --@@ -11,7 +12,6 @@   ) where  -------------------------------------------------------------------------------import           Control.Applicative import           Control.Concurrent import           Control.Monad import           Data.ByteString (ByteString)@@ -21,7 +21,11 @@ import           Numeric import           System.Random.MWC +#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif + ------------------------------------------------------------------------------ -- | High speed, mutable random number generator state newtype RNG = RNG (MVar GenIO)@@ -55,5 +59,3 @@ -- | Generate a randomized CSRF token mkCSRFToken :: RNG -> IO Text mkCSRFToken rng = T.decodeUtf8 <$> randomToken 40 rng--
src/Snap/Snaplet/Session/SecureCookie.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ -- | This is a support module meant to back all session back-end@@ -12,26 +13,30 @@ --     cookie. This will limit intercept-and-replay attacks by disallowing --     cookies older than the timeout threshold. -module Snap.Snaplet.Session.SecureCookie where---------------------------------------------------------------------------------import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Data.ByteString (ByteString)-import Data.Time-import Data.Time.Clock.POSIX-import Data.Serialize-import Snap.Core-import Web.ClientSession-+module Snap.Snaplet.Session.SecureCookie+       ( SecureCookie+       , getSecureCookie+       , setSecureCookie+       , expireSecureCookie+       -- ** Helper functions+       , encodeSecureCookie+       , decodeSecureCookie+       , checkTimeout+       ) where  --------------------------------------------------------------------------------- | Serialize UTCTime---instance Serialize UTCTime where---    put t = put (round (utcTimeToPOSIXSeconds t) :: Integer)---    get   = posixSecondsToUTCTime . fromInteger <$> get+import           Control.Monad+import           Control.Monad.Trans+import           Data.ByteString       (ByteString)+import           Data.Serialize+import           Data.Time+import           Data.Time.Clock.POSIX+import           Snap.Core+import           Web.ClientSession +#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif  ------------------------------------------------------------------------------ -- | Arbitrary payload with timestamp.@@ -39,7 +44,7 @@   --------------------------------------------------------------------------------- Get the payload back+-- | Get the cookie payload. getSecureCookie :: (MonadSnap m, Serialize t)                 => ByteString       -- ^ Cookie name                 -> Key              -- ^ Encryption key@@ -49,32 +54,66 @@     rqCookie <- getCookie name     rspCookie <- getResponseCookie name <$> getResponse     let ck = rspCookie `mplus` rqCookie-    let val = fmap cookieValue ck >>= decrypt key >>= return . decode-    let val' = val >>= either (const Nothing) Just-    case val' of+    let val = fmap cookieValue ck >>= decodeSecureCookie key+    case val of       Nothing -> return Nothing       Just (ts, t) -> do-          to <- checkTimeout timeout $ posixSecondsToUTCTime $ fromInteger ts+          to <- checkTimeout timeout ts           return $ case to of             True -> Nothing             False -> Just t   --------------------------------------------------------------------------------- | Inject the payload+-- | Decode secure cookie payload wih key.+decodeSecureCookie  :: Serialize a+                     => Key                     -- ^ Encryption key+                     -> ByteString              -- ^ Encrypted payload+                     -> Maybe (SecureCookie a)+decodeSecureCookie key value = do+    cv <- decrypt key value+    (i, val) <- either (const Nothing) Just $ decode cv+    return $ (posixSecondsToUTCTime (fromInteger i), val)+++------------------------------------------------------------------------------+-- | Inject the payload. setSecureCookie :: (MonadSnap m, Serialize t)                 => ByteString       -- ^ Cookie name+                -> Maybe ByteString -- ^ Cookie domain                 -> Key              -- ^ Encryption key                 -> Maybe Int        -- ^ Max age in seconds                 -> t                -- ^ Serializable payload                 -> m ()-setSecureCookie name key to val = do+setSecureCookie name domain key to val = do     t <- liftIO getCurrentTime-    let seconds = round (utcTimeToPOSIXSeconds t) :: Integer+    val' <- encodeSecureCookie key (t, val)     let expire = to >>= Just . flip addUTCTime t . fromIntegral-    val' <- liftIO . encryptIO key . encode $ (seconds, val)-    let nc = Cookie name val' expire Nothing (Just "/") False True+    let nc = Cookie name val' expire domain (Just "/") False True     modifyResponse $ addResponseCookie nc+++------------------------------------------------------------------------------+-- | Encode SecureCookie with key into injectable payload+encodeSecureCookie :: (MonadIO m, Serialize t)+                    => Key            -- ^ Encryption key+                    -> SecureCookie t -- ^ Payload+                    -> m ByteString+encodeSecureCookie key (t, val) =+    liftIO $ encryptIO key . encode $ (seconds, val)+  where+    seconds = round (utcTimeToPOSIXSeconds t) :: Integer+++------------------------------------------------------------------------------+-- | Expire secure cookie+expireSecureCookie :: MonadSnap m+                   => ByteString       -- ^ Cookie name+                   -> Maybe ByteString -- ^ Cookie domain+                   -> m ()+expireSecureCookie name domain = expireCookie cookie+  where+    cookie = Cookie name "" Nothing domain (Just "/") False False   ------------------------------------------------------------------------------
src/Snap/Snaplet/Test.hs view
@@ -38,7 +38,7 @@   --------------------------------------------------------------------------------- | Remove the given file before running an IO computation. Obviously it+-- | 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)
− src/Snap/Starter.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Main where---------------------------------------------------------------------------------import           Data.Char-import           Data.List-import qualified Data.ByteString.Char8 as S-import qualified Data.Text as T-import           Snap.Http.Server (snapServerVersion)-import           System.Directory-import           System.Environment-import           System.Exit-import           System.Console.GetOpt-import           System.FilePath--------------------------------------------------------------------------------import           Snap.StarterTH------------------------------------------------------------------------------------ Creates a value tDir :: ([String], [(String, String)])-buildData "tDirBareBones" "barebones"-buildData "tDirDefault" "default"-buildData "tDirTutorial" "tutorial"----------------------------------------------------------------------------------usage :: String-usage = unlines-    [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter"-    , ""-    , "Usage:"-    , ""-    , "  snap <action>"-    , ""-    , "    <action> can be one of:"-    , "      init - create a new project directory structure in the " ++-        "current directory"-    , ""-    , "  Note: you can use --help after any of the above actions to get help "-    , "  on that action"-    ]----------------------------------------------------------------------------------initUsage :: String-initUsage = unlines-    [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter"-    , ""-    , "Usage:"-    , ""-    , "  snap init [type]"-    , ""-    , "    [type] can be one of:"-    , "      default   - A default project using snaplets and heist"-    , "      barebones - A barebones project with minimal dependencies"-    , "      tutorial  - The literate Haskell tutorial project"-    , ""-    , "  If [type] is omitted, the default project is generated."-    ]----------------------------------------------------------------------------------printUsage :: [String] -> IO ()-printUsage ("init":_) = putStrLn initUsage-printUsage _ = putStrLn usage------------------------------------------------------------------------------------ Only one option for now-data Option = Help-  deriving (Show, Eq)----------------------------------------------------------------------------------setup :: String -> ([FilePath], [(String, String)]) -> IO ()-setup projName tDir = do-    mapM createDirectory (fst tDir)-    mapM_ write (snd tDir)-  where-    ---------------------------------------------------------------------------    write (f,c) =-        if isSuffixOf "foo.cabal" f-          then writeFile (projName ++ ".cabal") (insertProjName $ T.pack c)-          else writeFile f c--    ---------------------------------------------------------------------------    isNameChar c = isAlphaNum c || c == '-'--    ---------------------------------------------------------------------------    insertProjName c = T.unpack $ T.replace-                           (T.pack "projname")-                           (T.pack $ filter isNameChar projName) c----------------------------------------------------------------------------------initProject :: [String] -> IO ()-initProject args = do-    case getOpt Permute options args of-      (flags, other, [])-          | Help `elem` flags -> printUsage other >> exitFailure-          | otherwise         -> go other--      (_, other, errs) -> do putStrLn $ concat errs-                             printUsage other-                             exitFailure--  where-    ---------------------------------------------------------------------------    options =-        [ Option ['h'] ["help"]       (NoArg Help)-                 "Print this message"-        ]--    ---------------------------------------------------------------------------    go ("init":rest) = init' rest-    go _ = do-        putStrLn "Error: Invalid action!"-        putStrLn usage-        exitFailure--    ---------------------------------------------------------------------------    init' args' = do-        cur <- getCurrentDirectory-        let dirs     = splitDirectories cur-            projName = last dirs-            setup'   = setup projName--        case args' of-          []            -> setup' tDirDefault-          ["barebones"] -> setup' tDirBareBones-          ["default"]   -> setup' tDirDefault-          ["tutorial"]  -> setup' tDirTutorial-          _             -> do-            putStrLn initUsage-            exitFailure----------------------------------------------------------------------------------main :: IO ()-main = do-    args <- getArgs-    initProject args
− src/Snap/StarterTH.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Snap.StarterTH where---------------------------------------------------------------------------------import qualified Data.Foldable as F-import           Data.List-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import           System.Directory.Tree-import           System.FilePath------------------------------------------------------------------------------------------------------------------------------------------------------------------- Convenience types-type FileData = (String, String)-type DirData  = FilePath------------------------------------------------------------------------------------ Gets all the directories in a DirTree----getDirs :: [FilePath] -> DirTree a -> [FilePath]-getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) :-                           concatMap (getDirs (n:prefix)) c-getDirs _ (File _ _) = []-getDirs _ (Failed _ _) = []------------------------------------------------------------------------------------ Reads a directory and returns a tuple of the list of all directories--- encountered and a list of filenames and content strings.----readTree :: FilePath -> IO ([DirData], [FileData])-readTree dir = do-    d <- readDirectory $ dir </> "."-    let ps = zipPaths $ "" :/ (free d)-        fd = F.foldr (:) [] ps-        dirs = getDirs [] $ free d-    return (drop 1 dirs, fd)------------------------------------------------------------------------------------ Calls readTree and returns its value in a quasiquote.----dirQ :: FilePath -> Q Exp-dirQ tplDir = do-    d <- runIO . readTree $ "project_template" </> tplDir-    lift d------------------------------------------------------------------------------------ Creates a declaration assigning the specified name the value returned by--- dirQ.----buildData :: String -> FilePath -> Q [Dec]-buildData dirName tplDir = do-    let dir  = mkName dirName-    typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |]-    v       <- valD (varP dir) (normalB $ dirQ tplDir) []--    return [typeSig, v]
+ test/bad.tpl view
@@ -0,0 +1,1 @@+<bad template
+ test/db.cfg view
@@ -0,0 +1,2 @@+dbServer = "localhost"+dbPort = 1234
+ test/devel.cfg view
@@ -0,0 +1,5 @@+topConfigField = "topConfigValue"++db {+import "db.cfg"+}
− test/foosnaplet/devel.cfg 
@@ -1,2 +0,0 @@-fooSnapletField = "fooValue"-
− test/foosnaplet/templates/foopage.tpl 
@@ -1,1 +0,0 @@-foo template page
+ test/good.tpl view
@@ -0,0 +1,1 @@+Good template
− test/non-cabal-appdir/bad.tpl 
@@ -1,1 +0,0 @@-<bad template
− test/non-cabal-appdir/db.cfg 
@@ -1,3 +0,0 @@-dbServer = "localhost"-dbPort   = 1234-
− test/non-cabal-appdir/devel.cfg 
@@ -1,6 +0,0 @@-topConfigField = "topConfigValue"--db  {-import "db.cfg"-}-
− test/non-cabal-appdir/good.tpl 
@@ -1,1 +0,0 @@-Good template
− test/non-cabal-appdir/log/placeholder 
− test/non-cabal-appdir/snaplets/baz/devel.cfg 
@@ -1,2 +0,0 @@-barSnapletField = "barValue"-
− test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl 
@@ -1,1 +0,0 @@-baz config page <appconfig/> <fooconfig/>
− test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl 
@@ -1,1 +0,0 @@-baz template page <barsplice/>
− test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl 
@@ -1,1 +0,0 @@-This is an extra template
− test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl 
@@ -1,1 +0,0 @@-embedded snaplet page <asplice/>
− test/non-cabal-appdir/snaplets/heist/templates/index.tpl 
@@ -1,1 +0,0 @@-index page
− test/non-cabal-appdir/snaplets/heist/templates/page.tpl 
@@ -1,8 +0,0 @@-<html>-<head>-<title>Example App</title>-</head>-<body>-<apply-content/>-</body>-</html>
− test/non-cabal-appdir/snaplets/heist/templates/session.tpl 
@@ -1,1 +0,0 @@-<session/>
− test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl 
@@ -1,1 +0,0 @@-splice page <appsplice/>
− test/runTestsAndCoverage.sh 
@@ -1,65 +0,0 @@-#!/bin/sh--set -e--if [ -z "$DEBUG" ]; then-    export DEBUG=snap-testsuite-fi--SUITE=./dist/build/snap-testsuite/snap-testsuite--rm -f snap-testsuite.tix--if [ ! -f $SUITE ]; then-    cat <<EOF-Testsuite executable not found, please run:-    cabal configure-then-    cabal build-EOF-    exit;-fi--$SUITE $*--DIR=dist/hpc--rm -Rf $DIR-mkdir -p $DIR--EXCLUDES='Main-Blackbox.App-Blackbox.BarSnaplet-Blackbox.Common-Blackbox.EmbeddedSnaplet-Blackbox.FooSnaplet-Blackbox.Tests-Blackbox.Types-Snap.Snaplet.Auth.App-Snap.Snaplet.Auth.Handlers.Tests-Snap.Snaplet.Auth.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-'--EXCL=""--for m in $EXCLUDES; do-    EXCL="$EXCL --exclude=$m"-done--rm -f non-cabal-appdir/snaplets/heist/templates/bad.tpl-rm -f non-cabal-appdir/snaplets/heist/templates/good.tpl-rm -fr non-cabal-appdir/snaplets/foosnaplet--hpc markup $EXCL --destdir=$DIR snap-testsuite >/dev/null 2>&1--cat <<EOF--Test coverage report written to $DIR.-EOF
− test/snap-testsuite.cabal 
@@ -1,247 +0,0 @@-name:           snap-testsuite-version:        0.0.1-build-type:     Simple-cabal-version:  >= 1.8--Flag old-base-  default: False-  manual: False--Executable snap-testsuite-  hs-source-dirs:  ../src suite-  main-is:         TestSuite.hs--  build-depends:-    Glob                       >= 0.5      && < 0.8,-    HUnit                      >= 1.2      && < 2,-    QuickCheck                 >= 2.3.0.2,-    blaze-builder              >= 0.3      && < 0.4,-    http-streams               >= 0.4.0.1  && < 0.8,-    process                    == 1.*,-    smallcheck                 >= 0.6      && < 1.2,-    test-framework             >= 0.6      && < 0.9,-    test-framework-hunit       >= 0.2.7    && < 0.4,-    test-framework-quickcheck2 >= 0.2.12.1 && < 0.4,-    test-framework-smallcheck  >= 0.1      && < 0.3,-    unix                       >= 2.2.0.0  && < 2.8,--    MonadCatchIO-transformers  >= 0.2      && < 0.4,-    aeson                      >= 0.6      && < 0.10,-    attoparsec                 >= 0.10     && < 0.13,-    bytestring                 >= 0.9.1    && < 0.11,-    cereal                     >= 0.3      && < 0.5,-    clientsession              >= 0.8      && < 0.10,-    comonad                    >= 1.1      && < 4.3,-    configurator               >= 0.1      && < 0.4,-    containers                 >= 0.3      && < 0.6,-    directory                  >= 1.0      && < 1.3,-    directory-tree             >= 0.10     && < 0.13,-    dlist                      >= 0.5      && < 0.8,-    errors                     >= 1.4      && < 1.5,-    filepath                   >= 1.1      && < 1.4,-    -- Blacklist bad versions of hashable-    hashable                  (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),-    heist                      >= 0.14     && < 0.15,-    logict                     >= 0.4.2    && < 0.7,-    mtl                        >  2.0      && < 2.3,-    mwc-random                 >= 0.8      && < 0.14,-    pwstore-fast               >= 2.2      && < 2.5,-    regex-posix                >= 0.95     && < 1,-    snap-core                  >= 0.9      && < 0.11,-    snap-server                >= 0.9      && < 0.11,-    stm                        >= 2.2      && < 2.5,-    syb                        >= 0.1      && < 0.5,-    text                       >= 0.11     && < 1.3,-    time                       >= 1.1      && < 1.5,-    transformers               >= 0.2      && < 0.5,-    unordered-containers       >= 0.1.4    && < 0.3,-    vector                     >= 0.7.1    && < 0.12,-    vector-algorithms          >= 0.4      && < 0.7,-    xmlhtml                    >= 0.1      && < 0.3--  if flag(old-base)-    build-depends:-      base                      >= 4        && < 4.4,-      lens                      >= 3.7.6    && < 3.8-  else-    build-depends:-      base                      >= 4.4      && < 5,-      lens                      >= 3.7.6    && < 4.13---  extensions:-    BangPatterns,-    CPP,-    DeriveDataTypeable,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses,-    NoMonomorphismRestriction,-    OverloadedStrings,-    PackageImports,-    Rank2Types,-    ScopedTypeVariables,-    TemplateHaskell,-    TypeFamilies,-    TypeOperators,-    TypeSynonymInstances--  ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded-               -fno-warn-unused-do-bind---Executable app-  hs-source-dirs:  ../src suite-  main-is:         AppMain.hs--  build-depends:-    MonadCatchIO-transformers  >= 0.2      && < 0.4,-    aeson                      >= 0.6      && < 0.10,-    attoparsec                 >= 0.10     && < 0.13,-    bytestring                 >= 0.9.1    && < 0.11,-    cereal                     >= 0.3      && < 0.5,-    clientsession              >= 0.8      && < 0.10,-    comonad                    >= 1.1      && < 4.3,-    configurator               >= 0.1      && < 0.4,-    containers                 >= 0.3      && < 0.6,-    directory                  >= 1.0      && < 1.3,-    directory-tree             >= 0.10     && < 0.13,-    dlist                      >= 0.5      && < 0.8,-    errors                     >= 1.4      && < 1.5,-    filepath                   >= 1.1      && < 1.4,-    -- Blacklist bad versions of hashable-    hashable                  (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),-    heist                      >= 0.14     && < 0.15,-    logict                     >= 0.4.2    && < 0.7,-    mtl                        >  2.0      && < 2.3,-    mwc-random                 >= 0.8      && < 0.14,-    pwstore-fast               >= 2.2      && < 2.5,-    regex-posix                >= 0.95     && < 1,-    snap-core                  >= 0.9      && < 0.11,-    snap-server                >= 0.9      && < 0.11,-    stm                        >= 2.2      && < 2.5,-    syb                        >= 0.1      && < 0.5,-    text                       >= 0.11     && < 1.3,-    time                       >= 1.1      && < 1.5,-    transformers               >= 0.2      && < 0.5,-    unordered-containers       >= 0.1.4    && < 0.3,-    vector                     >= 0.7.1    && < 0.12,-    vector-algorithms          >= 0.4      && < 0.7,-    xmlhtml                    >= 0.1      && < 0.3--  if flag(old-base)-    build-depends:-      base                      >= 4        && < 4.4,-      lens                      >= 3.7.6    && < 3.8-  else-    build-depends:-      base                      >= 4.4      && < 5,-      lens                      >= 3.7.6    && < 4.13--  extensions:-    BangPatterns,-    CPP,-    DeriveDataTypeable,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses,-    NoMonomorphismRestriction,-    OverloadedStrings,-    PackageImports,-    Rank2Types,-    ScopedTypeVariables,-    TemplateHaskell,-    TypeFamilies,-    TypeOperators,-    TypeSynonymInstances--  ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded-               -fno-warn-unused-do-bind--Executable nesttest-  hs-source-dirs:  ../src suite-  main-is:         NestTest.hs--  build-depends:-    Glob                       >= 0.5      && < 0.8,-    HUnit                      >= 1.2      && < 2,-    QuickCheck                 >= 2.3.0.2,-    http-streams               >= 0.4.0.1  && < 0.8,-    process                    == 1.*,-    smallcheck                 >= 0.6      && < 1.2,-    test-framework             >= 0.6      && < 0.9,-    test-framework-hunit       >= 0.2.7    && < 0.4,-    test-framework-quickcheck2 >= 0.2.12.1 && < 0.4,-    test-framework-smallcheck  >= 0.1      && < 0.3,-    unix                       >= 2.2.0.0  && < 2.8,--    MonadCatchIO-transformers  >= 0.2      && < 0.4,-    aeson                      >= 0.6      && < 0.10,-    attoparsec                 >= 0.10     && < 0.13,-    bytestring                 >= 0.9.1    && < 0.11,-    cereal                     >= 0.3      && < 0.5,-    clientsession              >= 0.8      && < 0.10,-    comonad                    >= 1.1      && < 4.3,-    configurator               >= 0.1      && < 0.4,-    containers                 >= 0.3      && < 0.6,-    directory                  >= 1.0      && < 1.3,-    directory-tree             >= 0.10     && < 0.13,-    dlist                      >= 0.5      && < 0.8,-    errors                     >= 1.4      && < 1.5,-    filepath                   >= 1.1      && < 1.4,-    -- Blacklist bad versions of hashable-    hashable                  (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),-    heist                      >= 0.14     && < 0.15,-    logict                     >= 0.4.2    && < 0.7,-    mtl                        >  2.0      && < 2.3,-    mwc-random                 >= 0.8      && < 0.14,-    pwstore-fast               >= 2.2      && < 2.5,-    regex-posix                >= 0.95     && < 1,-    snap-core                  >= 0.9      && < 0.11,-    snap-server                >= 0.9      && < 0.11,-    stm                        >= 2.2      && < 2.5,-    syb                        >= 0.1      && < 0.5,-    text                       >= 0.11     && < 1.3,-    time                       >= 1.1      && < 1.5,-    transformers               >= 0.2      && < 0.5,-    unordered-containers       >= 0.1.4    && < 0.3,-    vector                     >= 0.7.1    && < 0.12,-    vector-algorithms          >= 0.4      && < 0.7,-    xmlhtml                    >= 0.1      && < 0.3--  if flag(old-base)-    build-depends:-      base                      >= 4        && < 4.4,-      lens                      >= 3.7.6    && < 3.8-  else-    build-depends:-      base                      >= 4.4      && < 5,-      lens                      >= 3.7.6    && < 4.13---  extensions:-    BangPatterns,-    CPP,-    DeriveDataTypeable,-    ExistentialQuantification,-    FlexibleContexts,-    FlexibleInstances,-    GeneralizedNewtypeDeriving,-    MultiParamTypeClasses,-    NoMonomorphismRestriction,-    OverloadedStrings,-    PackageImports,-    Rank2Types,-    ScopedTypeVariables,-    TemplateHaskell,-    TypeFamilies,-    TypeOperators,-    TypeSynonymInstances--  ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded-               -fno-warn-unused-do-bind-
+ test/snaplets/baz/devel.cfg view
@@ -0,0 +1,2 @@+barSnapletField = "barValue"+
+ test/snaplets/baz/templates/bazconfig.tpl view
@@ -0,0 +1,1 @@+baz config page <appconfig/> <fooconfig/>
+ test/snaplets/baz/templates/bazpage.tpl view
@@ -0,0 +1,1 @@+baz template page <barsplice/>
+ test/snaplets/embedded/extra-templates/extra.tpl view
@@ -0,0 +1,1 @@+This is an extra template
+ test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl view
@@ -0,0 +1,1 @@+embedded snaplet page <asplice/>
+ test/snaplets/foosnaplet/devel.cfg view
@@ -0,0 +1,2 @@+fooSnapletField = "fooValue"+
+ test/snaplets/foosnaplet/templates/foopage.tpl view
@@ -0,0 +1,1 @@+foo template page
+ test/snaplets/heist/templates/_foopage.tpl view
@@ -0,0 +1,7 @@+<html>+  <head></head>+  <body>+    <p>An underscore template.</p>+    <someSplice/>+  </body>+</html>
+ test/snaplets/heist/templates/extraTemplates/barpage.tpl view
@@ -0,0 +1,4 @@+<html>+<head></head>+<body>Hi. Bar.</body>+</html>
+ test/snaplets/heist/templates/foopage.tpl view
@@ -0,0 +1,6 @@+<html>+  <head></head>+  <body>Hi.+    <aSplice/>+  </body>+</html>
+ test/snaplets/heist/templates/index.tpl view
@@ -0,0 +1,1 @@+index page
+ test/snaplets/heist/templates/page.tpl view
@@ -0,0 +1,8 @@+<html>+<head>+<title>Example App</title>+</head>+<body>+<apply-content/>+</body>+</html>
+ test/snaplets/heist/templates/session.tpl view
@@ -0,0 +1,1 @@+<session/>
+ test/snaplets/heist/templates/splicepage.tpl view
@@ -0,0 +1,1 @@+splice page <appsplice/>
+ test/snaplets/heist/templates/userpage.tpl view
@@ -0,0 +1,50 @@+<html>++  <head></head>++  <body>++    <userSplice>+      <h2>+	<ifLoggedIn>+	  <loggedInUser/> is logged in+	</ifLoggedIn>+	+	<ifLoggedOut>+	  You are not logged in+	</ifLoggedOut>+      </h2>++      <h3>loggedInUser: <loggedInUser/></h3>++      <p>UserID <userId/></p>++      <p>UserLogin <userLogin/></p>+      +      <p>UserEmail <userEmail/></p>++      <p>UserActive <userActive/></p>+      +      <p>UserLoginCount <userLoginCount/></p>+      +      <p>UserFailedCount <userFailedCount/></p>+      +      <p>UserLoginAt <userLoginAt/></p>+      +      <p>UserLastLoginAt <userLastLoginAt/></p>+      +      <p>UserSuspendedAt <userSuspendedAt/></p>+      +      <p>UserLoginIP <userLoginIP/></p>+      +      <p>UserLastLoginIP <userLastLoginIP/></p>+      +      <p>UserIfActive <userIfActive/></p>+      +      <p>userIfSuspended <userIfSuspended/></p>+      +    </userSplice>+    +  </body>+  +</html>
− test/suite/AppMain.hs 
@@ -1,9 +0,0 @@-module Main where--import           Snap.Http.Server.Config-import           Snap.Snaplet--import           Blackbox.App--main :: IO ()-main = serveSnaplet defaultConfig app
− test/suite/Blackbox/App.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Blackbox.App where----------------------------------------------------------------------------------import Prelude hiding (lookup)---------------------------------------------------------------------------------import Control.Applicative-import Control.Lens-import Control.Monad.Trans-import Data.Maybe-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Configurator-import Snap.Core-import Snap.Util.FileServe---------------------------------------------------------------------------------import Snap.Snaplet-import Snap.Snaplet.Heist-import qualified Snap.Snaplet.HeistNoClass as HNC-import Heist-import Heist.Interpreted---------------------------------------------------------------------------------import Blackbox.Common-import Blackbox.BarSnaplet-import Blackbox.FooSnaplet-import Blackbox.EmbeddedSnaplet-import Blackbox.Types-import Snap.Snaplet.Session-import Snap.Snaplet.Session.Backends.CookieSession---                            ---------------------                            --  THE SNAPLET   ---                            ---------------------  --------------------------------------------------------------------------------app :: SnapletInit App App-app = makeSnaplet "app" "Test application" Nothing $ do-    hs <- nestSnaplet "heist" heist $ heistInit "templates"-    fs <- nestSnaplet "foo" foo $ fooInit hs-    bs <- nestSnaplet "" bar $ nameSnaplet "baz" $ barInit hs foo-    sm <- nestSnaplet "session" session $-          initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60))-    ns <- embedSnaplet "embed" embedded embeddedInit-    _lens <- getLens-    let splices = do-            "appsplice" ## textSplice "contents of the app splice"-            "appconfig" ## shConfigSplice _lens-    addConfig hs $ mempty & scInterpretedSplices .~ splices-    addRoutes [ ("/hello", writeText "hello world")-              , ("/routeWithSplice", routeWithSplice)-              , ("/routeWithConfig", routeWithConfig)-              , ("/public", serveDirectory "public")-              , ("/sessionDemo", sessionDemo)-              , ("/sessionTest", sessionTest)-              ]-    wrapSite (<|> heistServe)-    return $ App hs (over snapletValue fooMod fs) bs sm ns-----------------------------------------------------------------------------------routeWithSplice :: Handler App App ()-routeWithSplice = do-    str <- with foo getFooField-    writeText $ T.pack $ "routeWithSplice: "++str----------------------------------------------------------------------------------routeWithConfig :: Handler App App ()-routeWithConfig = do-    cfg <- getSnapletUserConfig-    val <- liftIO $ lookup cfg "topConfigField"-    writeText $ "routeWithConfig: " `T.append` fromJust val----------------------------------------------------------------------------------sessionDemo :: Handler App App ()-sessionDemo = withSession session $ do-  with session $ do-    curVal <- getFromSession "foo"-    case curVal of-      Nothing -> setInSession "foo" "bar"-      Just _ -> return ()-  list <- with session $ (T.pack . show) `fmap` sessionToList-  csrf <- with session $ (T.pack . show) `fmap` csrfToken-  HNC.renderWithSplices heist "session" $ do-    "session" ## textSplice list-    "csrf" ## textSplice csrf----------------------------------------------------------------------------------sessionTest :: Handler App App ()-sessionTest = withSession session $ do-  q <- getParam "q"-  val <- case q of-    Just x -> do-      let x' = T.decodeUtf8 x-      with session $ setInSession "test" x'-      return x'-    Nothing -> fromMaybe "" `fmap` with session (getFromSession "test")-  writeText val--fooMod :: FooSnaplet -> FooSnaplet-fooMod f = f { fooField = fooField f ++ "z" }-
− test/suite/Blackbox/BarSnaplet.hs 
@@ -1,54 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-module Blackbox.BarSnaplet where--import Prelude hiding (lookup)--import Control.Lens-import Control.Monad.State-import qualified Data.ByteString as B-import Data.Configurator-import Data.Maybe-import Snap.Snaplet-import Snap.Snaplet.Heist-import Snap.Core-import Heist-import Heist.Interpreted--import Blackbox.Common-import Blackbox.FooSnaplet--data BarSnaplet b = BarSnaplet-    { _barField :: String-    , fooLens  :: SnapletLens b FooSnaplet-    }--makeLenses ''BarSnaplet--barsplice :: Splices (SnapletISplice b)-barsplice = "barsplice" ## textSplice "contents of the bar splice"--barInit :: HasHeist b-        => Snaplet (Heist b)-        -> SnapletLens b FooSnaplet-        -> SnapletInit b (BarSnaplet b)-barInit h l = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do-    config <- getSnapletUserConfig-    addTemplates h ""-    rootUrl <- getSnapletRootURL-    _lens <- getLens-    addRoutes [("barconfig", liftIO (lookup config "barSnapletField") >>= writeLBS . fromJust)-              ,("barrooturl", writeBS $ "url" `B.append` rootUrl)-              ,("bazpage2",   renderWithSplices "bazpage" barsplice)-              ,("bazpage3",   heistServeSingle "bazpage")-              ,("bazpage4",   renderAs "text/html" "bazpage")-              ,("bazpage5",   renderWithSplices "bazpage"-                                ("barsplice" ## shConfigSplice _lens))-              ,("bazbadpage", heistServeSingle "cpyga")-              ,("bar/handlerConfig", handlerConfig)-              ]-    return $ BarSnaplet "bar snaplet data string" l-
− test/suite/Blackbox/Common.hs 
@@ -1,25 +0,0 @@-module Blackbox.Common where--import Control.Lens-import Control.Monad.Trans-import qualified Data.Text as T-import Snap.Core-import Snap.Snaplet-import Snap.Snaplet.Heist-import Heist.Interpreted--genericConfigString :: (MonadSnaplet m, Monad (m b v)) => m b v T.Text-genericConfigString = do-    a <- getSnapletAncestry-    b <- getSnapletFilePath-    c <- getSnapletName-    d <- getSnapletDescription-    e <- getSnapletRootURL-    return $ T.pack $ show (a,b,c,d,e)--handlerConfig :: Handler b v ()-handlerConfig = writeText =<< genericConfigString--shConfigSplice :: SnapletLens (Snaplet b) v -> SnapletISplice b-shConfigSplice _lens = textSplice =<< lift (with' _lens genericConfigString)-
− test/suite/Blackbox/EmbeddedSnaplet.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Blackbox.EmbeddedSnaplet where--import Prelude hiding ((.))-import Control.Lens-import Control.Monad.State-import qualified Data.Text as T-import System.FilePath.Posix--import Snap.Snaplet-import Snap.Snaplet.Heist-import Heist-import Heist.Interpreted---- If we universally quantify EmbeddedSnaplet to get rid of the type parameter--- mkLabels throws an error "Can't reify a GADT data constructor"-data EmbeddedSnaplet = EmbeddedSnaplet-    { _embeddedHeist :: Snaplet (Heist EmbeddedSnaplet)-    , _embeddedVal :: Int-    }--makeLenses ''EmbeddedSnaplet--instance HasHeist EmbeddedSnaplet where-    heistLens = subSnaplet embeddedHeist--embeddedInit :: SnapletInit EmbeddedSnaplet EmbeddedSnaplet-embeddedInit = makeSnaplet "embedded" "embedded snaplet" Nothing $ do-    hs <- nestSnaplet "heist" embeddedHeist $ heistInit "templates"--    -- This is the implementation of addTemplates, but we do it here manually-    -- to test coverage for addTemplatesAt.-    snapletPath <- getSnapletFilePath-    addTemplatesAt hs "onemoredir" (snapletPath </> "extra-templates")--    embeddedLens <- getLens-    addRoutes [("aoeuhtns", withSplices-                    ("asplice" ## embeddedSplice embeddedLens)-                    (render "embeddedpage"))-              ]-    return $ EmbeddedSnaplet hs 42---embeddedSplice :: (SnapletLens (Snaplet b) EmbeddedSnaplet)-               -> SnapletISplice b-embeddedSplice embeddedLens = do-    val <- lift $ with' embeddedLens $ gets _embeddedVal-    textSplice $ T.pack $ "splice value" ++ (show val)-
− test/suite/Blackbox/FooSnaplet.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-module Blackbox.FooSnaplet where--import Prelude hiding (lookup)-import Control.Lens-import Control.Monad.State-import Data.Configurator-import Data.Maybe-import Data.Monoid-import qualified Data.Text as T-import Snap.Snaplet-import Snap.Snaplet.Heist-import Snap.Core-import Heist-import Heist.Interpreted--import Blackbox.Common--data FooSnaplet = FooSnaplet { fooField :: String }--fooInit :: HasHeist b => Snaplet (Heist b) -> SnapletInit b FooSnaplet-fooInit h = makeSnaplet "foosnaplet" "A demonstration snaplet called foo."-    (Just $ return "../foosnaplet") $ do-    config <- getSnapletUserConfig-    addTemplates h ""-    rootUrl <- getSnapletRootURL-    fp <- getSnapletFilePath-    name <- getSnapletName-    _lens <- getLens-    let splices = do-            "foosplice" ## textSplice "contents of the foo splice"-            "fooconfig" ## shConfigSplice _lens-    addConfig h $ mempty & scInterpretedSplices .~ splices-    addRoutes [("fooConfig", liftIO (lookup config "fooSnapletField") >>= writeLBS . fromJust)-              ,("fooRootUrl", writeBS rootUrl)-              ,("fooSnapletName", writeText $ fromMaybe "empty snaplet name" name)-              ,("fooFilePath", writeText $ T.pack fp)-              ,("handlerConfig", handlerConfig)-              ]-    return $ FooSnaplet "foo snaplet data string"--getFooField :: Handler b FooSnaplet String-getFooField = gets fooField-
test/suite/Blackbox/Tests.hs view
@@ -8,9 +8,7 @@   ) where  -------------------------------------------------------------------------------import           Blaze.ByteString.Builder       (Builder)-import qualified Blaze.ByteString.Builder       as Builder-import           Control.Exception              (catch, throwIO)+import           Control.Exception              (catch, finally, throwIO) import           Control.Monad import           Control.Monad.Trans import qualified Data.ByteString.Char8          as S@@ -26,12 +24,9 @@ import           Test.Framework                 (Test, testGroup) import           Test.Framework.Providers.HUnit import           Test.HUnit                     hiding (Test, path)- ------------------------------------------------------------------------------  -- ------------------------------------------------------------------------------ testServer :: String testServer = "http://127.0.0.1"@@ -57,7 +52,7 @@                             --------------------                             --  TEST LOADER   --                             ---------------------  + ------------------------------------------------------------------------------ tests :: Test tests = testGroup "non-cabal-tests"@@ -76,7 +71,7 @@     , requestTest "bazpage3" "baz template page <barsplice></barsplice>\n"     , requestTest "bazpage4" "baz template page <barsplice></barsplice>\n"     , requestTest "barrooturl" "url"-    , requestExpectingError "bazbadpage" 500 "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found."+    , requestExpectingErrorPrefix "bazbadpage" 500 "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found."     , requestTest "foo/fooSnapletName" "foosnaplet"      , fooConfigPathTest@@ -100,7 +95,7 @@ ------------------------------------------------------------------------------ testName :: String -> String testName uri = "internal/" ++ uri-+--testName = id  ------------------------------------------------------------------------------ requestTest :: String -> Text -> Test@@ -115,27 +110,27 @@   -------------------------------------------------------------------------------requestExpectingError :: String -> Int -> Text -> Test-requestExpectingError url status desired =-    testCase (testName url) $ requestExpectingError' url status desired+requestExpectingErrorPrefix :: String -> Int -> Text -> Test+requestExpectingErrorPrefix url status desired =+    testCase (testName url) $ requestExpectingErrorPrefix' url status desired   -------------------------------------------------------------------------------requestExpectingError' :: String -> Int -> Text -> IO ()-requestExpectingError' url status desired = do+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-      assertEqual fullUrl desired (T.decodeUtf8 $ L.fromChunks [res])+      assertBool fullUrl $ desired `T.isPrefixOf` (T.decodeUtf8 $ L.fromChunks [res])   ------------------------------------------------------------------------------ fooConfigPathTest :: Test fooConfigPathTest = testCase (testName "foo/fooFilePath") $ do     b <- liftM L.unpack $ grab "/foo/fooFilePath"-    assertRelativelyTheSame b "non-cabal-appdir/snaplets/foosnaplet"+    assertRelativelyTheSame b "snaplets/foosnaplet"   ------------------------------------------------------------------------------@@ -178,7 +173,7 @@ fooHandlerConfigTest = testWithCwd "foo/handlerConfig" $ \cwd b -> do     let response = L.fromChunks [ "([\"app\"],\""                                 , S.pack cwd-                                , "/non-cabal-appdir/snaplets/foosnaplet\","+                                , "/snaplets/foosnaplet\","                                 , "Just \"foosnaplet\",\"A demonstration "                                 , "snaplet called foo.\",\"foo\")" ]     assertEqual "" response b@@ -189,7 +184,7 @@ barHandlerConfigTest = testWithCwd "bar/handlerConfig" $ \cwd b -> do     let response = L.fromChunks [ "([\"app\"],\""                                 , S.pack cwd-                                , "/non-cabal-appdir/snaplets/baz\","+                                , "/snaplets/baz\","                                 , "Just \"baz\",\"An example snaplet called "                                 , "bar.\",\"\")" ]     assertEqual "" response b@@ -201,7 +196,7 @@ bazpage5Test = testWithCwd "bazpage5" $ \cwd b -> do     let response = L.fromChunks [ "baz template page ([\"app\"],\""                                 , S.pack cwd-                                , "/non-cabal-appdir/snaplets/baz\","+                                , "/snaplets/baz\","                                 , "Just \"baz\",\"An example snaplet called "                                 , "bar.\",\"\")\n" ]     assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b)@@ -216,11 +211,11 @@     let response = L.fromChunks [                      "baz config page ([],\""                    , S.pack cwd-                   , "/non-cabal-appdir\",Just \"app\","+                   , "\",Just \"app\"," -- TODO, right?                    , "\"Test application\",\"\") "                    , "([\"app\"],\""                    , S.pack cwd-                   , "/non-cabal-appdir/snaplets/foosnaplet\","+                   , "/snaplets/foosnaplet\","                    , "Just \"foosnaplet\",\"A demonstration snaplet "                    , "called foo.\",\"foo\")\n"                    ]@@ -251,82 +246,92 @@ removeDir :: FilePath -> IO () removeDir d = do     exists <- doesDirectoryExist d-    when exists $ removeDirectoryRecursive "non-cabal-appdir/snaplets/foosnaplet"+    when exists $ removeDirectoryRecursive "snaplets/foosnaplet"   ------------------------------------------------------------------------------ reloadTest :: Test reloadTest = testCase "internal/reload-test" $ do-    let goodTplOrig = "non-cabal-appdir" </> "good.tpl"-    let badTplOrig  = "non-cabal-appdir" </> "bad.tpl"-    let goodTplNew  = "non-cabal-appdir" </> "snaplets"  </> "heist"-                                         </> "templates" </> "good.tpl"-    let badTplNew   = "non-cabal-appdir" </> "snaplets"  </> "heist"-                                         </> "templates" </> "bad.tpl"+    let goodTplOrig = "good.tpl"+    let badTplOrig  = "bad.tpl"+    let goodTplNew  = "snaplets"  </> "heist"+                      </> "templates" </> "good.tpl"+    let badTplNew   = "snaplets"  </> "heist"+                      </> "templates" </> "bad.tpl"      goodExists <- doesFileExist goodTplNew     badExists  <- doesFileExist badTplNew      assertBool "good.tpl exists" (not goodExists)-    assertBool "bad.tpl exists" (not badExists)+    assertBool "bad.tpl exists"  (not badExists)     expect404 "bad"      copyFile badTplOrig badTplNew     expect404 "good"     expect404 "bad" -    testWithCwd' "admin/reload" $ \cwd' b -> do-        let cwd = S.pack cwd'-        let response =-                T.concat     [ "Error reloading site!\n\nInitializer "-                             , "threw an exception...\n"-                             , T.pack cwd'-                             , "/non-cabal-appdir/snaplets/heist"-                             , "/templates/bad.tpl \""-                             , T.pack cwd'-                             , "/non-cabal-appdir/snaplets/heist/templates"-                             , "/bad.tpl\" (line 2, column 1):\nunexpected "-                             , "end of input\nexpecting \"=\", \"/\" or "-                             , "\">\"\n\n...but before it died it generated "-                             , "the following output:\nInitializing app @ /\n"-                             , "Initializing heist @ /heist\n\n" ]-        assertEqual "admin/reload" response (T.decodeUtf8 b)+    flip finally (remove badTplNew) $+      testWithCwd' "admin/reload" $ \cwd' b -> do+        let cwd = T.pack cwd' -    remove badTplNew+        let prefix = T.intercalate "\n"+              [ "Error reloading site!"+              , ""+              , "Initializer threw an exception..."+              , T.concat+                [ cwd, "/snaplets/heist/templates/bad.tpl \""+                , cwd, "/snaplets/heist/templates/bad.tpl\" (line 2, column 1):"+                ]+              , "unexpected end of input"+              , "expecting \"=\", \"/\" or \">\""++              -- Building with the latest dependency versions produces the following:+              -- "CallStack (from HasCallStack):"+              -- "  error, called at src/Snap/Snaplet/Heist/Internal.hs:75:35 in main:Snap.Snaplet.Heist.Internal"+              ]++        let suffix = T.intercalate "\n"+              [ "...but before it died it generated the following output:"+              , "Initializing app @ /"+              , "Initializing heist @ /heist"+              , ""+              , ""+              ]++        let response = T.decodeUtf8 b++        assertEqual "admin/reload" prefix (T.take    (T.length prefix) response)+        assertEqual "admin/reload" suffix (T.takeEnd (T.length suffix) response)+     copyFile goodTplOrig goodTplNew -    testWithCwd' "admin/reload" $ \cwd' b -> do+    testWithCwd' "admin/reload" $ \cwd' b -> do  -- TODO/NOTE: Needs cleanup         let cwd = S.pack cwd'-        let response =-                L.fromChunks [ "Initializing app @ /\n"-                             , "Initializing heist @ /heist\n"-                             , "...loaded 5 templates from "-                             , cwd-                             , "/non-cabal-appdir/snaplets/heist/templates\n"-                             , "Initializing foosnaplet @ /foo\n"-                             , "...adding 1 templates from "-                             , cwd-                             , "/non-cabal-appdir/snaplets/foosnaplet"-                             , "/templates with route prefix foo/\n"-                             , "Initializing baz @ /\n"-                             , "...adding 2 templates from "-                             , cwd-                             , "/non-cabal-appdir/snaplets/baz/templates "-                             , "with route prefix /\n"-                             , "Initializing CookieSession @ /session\n"-                             , "Initializing embedded @ /\n"-                             , "Initializing heist @ /heist\n"-                             , "...loaded 1 templates from "-                             , cwd-                             , "/non-cabal-appdir/snaplets/embedded"-                             , "/snaplets/heist/templates\n"-                             , "...adding 1 templates from "-                             , cwd-                             , "/non-cabal-appdir/snaplets/embedded"-                             , "/extra-templates with route prefix "-                             , "onemoredir/\n"-                             , "Site successfully reloaded.\n"-                             ]+        let response = L.fromChunks [+              "Initializing app @ /\nInitializing heist @ ",+              "/heist\n...loaded 9 templates from ",+              cwd,+              "/snaplets/heist/templates\nInitializing CookieSession ",+              "@ /session\nInitializing foosnaplet @ /foo\n...adding 1 ",+              "templates from ",+              cwd,+              "/snaplets/foosnaplet/templates with route prefix ",+              "foo/\nInitializing baz @ /\n...adding 2 templates from ",+              cwd,+              "/snaplets/baz/templates with route prefix /\nInitializing ",+              "embedded @ /\nInitializing heist @ /heist\n...loaded ",+              "1 templates from ",+              cwd,+              "/snaplets/embedded/snaplets/heist/templates\n...adding ",+              "1 templates from ",+              cwd,+              "/snaplets/embedded/extra-templates with route prefix ",+              "onemoredir/\n...adding 0 templates from ",+              cwd,+              "/templates with route prefix extraTemplates/\n",+              "Initializing JsonFileAuthManager @ ",+              "/auth\nSite successfully reloaded.\n"+              ]          assertEqual "admin/reload" response b 
− test/suite/Blackbox/Types.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Blackbox.Types where---import Control.Lens--import Snap.Snaplet-import Snap.Snaplet.Heist--import Blackbox.FooSnaplet-import Blackbox.BarSnaplet-import Blackbox.EmbeddedSnaplet-import Snap.Snaplet.Session---data App = App-    { _heist :: Snaplet (Heist App)-    , _foo :: Snaplet FooSnaplet-    , _bar :: Snaplet (BarSnaplet App)-    , _session :: Snaplet SessionManager-    , _embedded :: Snaplet EmbeddedSnaplet-    }--makeLenses ''App--instance HasHeist App where heistLens = subSnaplet heist-
− test/suite/NestTest.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Main where--import Prelude hiding ((.))-import Control.Lens-import Control.Monad.State-import qualified Data.Text as T-import           Snap.Http.Server.Config-import Snap.Core-import Snap.Util.FileServe--import Snap.Snaplet-import Snap.Snaplet.Heist-import Heist-import Heist.Interpreted---- If we universally quantify FooSnaplet to get rid of the type parameter--- mkLabels throws an error "Can't reify a GADT data constructor"-data FooSnaplet = FooSnaplet-    { _fooHeist :: Snaplet (Heist FooSnaplet)-    , _fooVal :: Int-    }--makeLenses ''FooSnaplet--instance HasHeist FooSnaplet where-    heistLens = subSnaplet fooHeist--fooInit :: SnapletInit FooSnaplet FooSnaplet-fooInit = makeSnaplet "foosnaplet" "foo snaplet" Nothing $ do-    hs <- nestSnaplet "heist" fooHeist $ heistInit "templates"-    addTemplates hs "foo"-    rootUrl <- getSnapletRootURL-    fooLens <- getLens-    addRoutes [("fooRootUrl", writeBS rootUrl)-              ,("aoeuhtns", renderWithSplices "foo/foopage"-                    ("asplice" ## fooSplice fooLens))-              ,("", heistServe)-              ]-    return $ FooSnaplet hs 42-----fooSplice :: (Lens (Snaplet b) (Snaplet (FooSnaplet b)))---          -> SnapletSplice (Handler b b)-fooSplice :: (SnapletLens (Snaplet b) FooSnaplet)-          -> SnapletISplice b-fooSplice fooLens = do-    val <- lift $ with' fooLens $ gets _fooVal-    textSplice $ T.pack $ "splice value" ++ (show val)----------------------------------------------------------------------------------data App = App-    { _foo :: Snaplet (FooSnaplet)-    }--makeLenses ''App--app :: SnapletInit App App-app = makeSnaplet "app" "nested snaplet application" Nothing $ do-    fs <- embedSnaplet "foo" foo fooInit-    addRoutes [ ("/hello", writeText "hello world")-              , ("/public", serveDirectory "public")-              ]-    return $ App fs--main :: IO ()-main = serveSnaplet defaultConfig app-
+ 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/Lensed/Tests.hs view
@@ -6,7 +6,7 @@ import           Control.Category import           Control.Exception import           Control.Lens-import           Control.Monad.State.Strict+import           Control.Monad.State.Lazy import           Prelude hiding (catch, (.)) import           Test.Framework import           Test.Framework.Providers.HUnit
test/suite/Snap/Snaplet/Internal/Tests.hs view
@@ -7,20 +7,18 @@   ( tests, initTest ) where  -------------------------------------------------------------------------------import           Control.Lens-import           Control.Monad-import           Control.Monad.Trans-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import           Data.List-import           Data.Text (Text)-import           Prelude hiding (catch, (.))-import           System.Directory-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.Framework.Providers.SmallCheck-import           Test.HUnit hiding (Test, path)-import           Test.SmallCheck+import           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
+ 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,148 +1,82 @@-{-# LANGUAGE ScopedTypeVariables #-}- module Snap.TestCommon where  -------------------------------------------------------------------------------import Control.Concurrent   ( threadDelay                )-import Control.Exception    ( ErrorCall(..)-                            , SomeException-                            , bracket-                            , catch-                            , throwIO-                            )-import Control.Monad        ( forM_                      )-import Data.Maybe           ( fromMaybe                  )-import Data.Monoid          ( First(..), mconcat         )-import Prelude       hiding ( catch                      )-import System.Cmd           ( system                     )-import System.Directory     ( doesFileExist-                            , getCurrentDirectory-                            , findExecutable-                            , removeFile-                            )-import System.Environment   ( getEnv                     )-import System.Exit          ( ExitCode(..)               )-import System.FilePath      ( joinPath, splitPath, (</>) )-import System.FilePath.Glob ( compile, globDir1          )-import System.Process       ( runCommand-                            , terminateProcess-                            , waitForProcess-                            )-+import           Control.Exception               (try, SomeException)+import           Control.Monad.Trans             (lift)+import qualified Data.Text                       as T+import qualified GHC.Read                        as R+import           Test.HUnit                      (Assertion, assertFailure, assertBool)+import qualified Text.ParserCombinators.ReadPrec as R -------------------------------------------------------------------------------import SafeCWD+import Snap.Core+import Snap.Snaplet+import Snap.Snaplet.Heist+import Heist.Interpreted   -------------------------------------------------------------------------------testGeneratedProject :: String  -- ^ project name and directory-                     -> String  -- ^ arguments to @snap init@-                     -> String  -- ^ arguments to @cabal install@-                     -> Int     -- ^ port to run http server on-                     -> IO ()   -- ^ action to run when the server goes up-                     -> IO ()-testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort-                     testAction = do-    cwd <- getCurrentDirectory+expectException :: String -> IO a -> IO ()+expectException s m = do+  r <- try m+  case r of+    Left (e::SomeException) -> length (show e) `seq` return ()+    Right _ -> assertFailure s -    ---------------------------------------------------------------------------    let segments     = reverse $ splitPath cwd-        projectPath  = cwd </> "test-snap-exe" </> projName-        snapRoot     = joinPath $ reverse $ drop 1 segments-        snapRepos    = joinPath $ reverse $ drop 2 segments-        sandbox      = cwd </> "test-cabal-dev"-        cabalDevArgs = "-s " ++ sandbox-        args         = cabalDevArgs ++ " --reinstall " ++ cabalInstallArgs -        -----------------------------------------------------------------------        initialize = do-            snapExe <- findSnap-            systemOrDie $ snapExe ++ " init " ++ snapInitArgs--            snapCoreSrc     <- fromEnv "SNAP_CORE_SRC" $-                               snapRepos </> "snap-core"-            snapServerSrc   <- fromEnv "SNAP_SERVER_SRC" $-                               snapRepos </> "snap-server"-            xmlhtmlSrc      <- fromEnv "XMLHTML_SRC" $ snapRepos </> "xmlhtml"-            heistSrc        <- fromEnv "HEIST_SRC" $ snapRepos </> "heist"-            dynLoaderSrc    <- fromEnv "DYNAMIC_LOADER_SRC" $-                               snapRepos </> "snap-loader-dynamic"-            staticLoaderSrc <- fromEnv "STATIC_LOADER_SRC" $-                               snapRepos </> "snap-loader-static"-            let snapSrc   =  snapRoot--            forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap"-                  , "snap-loader-static", "snap-loader-dynamic"]-                  (pkgCleanUp sandbox)--            forM_ [ snapCoreSrc, snapServerSrc, xmlhtmlSrc, heistSrc-                  , snapSrc, staticLoaderSrc, dynLoaderSrc] $ \s ->-                systemOrDie $ concat [ "cabal-dev "-                                     , cabalDevArgs-                                     , " add-source "-                                     , s-                                     ]--            systemOrDie $ "cabal-dev install " ++ args-            let cmd = ("." </> "dist" </> "build" </> projName </> projName)-                      ++ " -p " ++ show httpPort-            putStrLn $ "Running \"" ++ cmd ++ "\""-            pHandle <- runCommand cmd-            waitABit-            return pHandle--        -----------------------------------------------------------------------        findSnap = do-            home <- fromEnv "HOME" "."-            p1   <- gimmeIfExists $ snapRoot </> "dist" </> "build"-                                             </> "snap" </> "snap"-            p2   <- gimmeIfExists $ home </> ".cabal" </> "bin" </> "snap"-            p3   <- findExecutable "snap"--            return $ fromMaybe (error "couldn't find snap executable")-                               (getFirst $ mconcat $ map First [p1,p2,p3])+------------------------------------------------------------------------------+showTestCase :: Show a => a -> Assertion+showTestCase a = assertBool "Show instance failed" $+                 ((showsPrec 5 a) "" == show a)+                 && (showList [a]) "" == "[" ++ show a ++ "]"+                  -    ---------------------------------------------------------------------------    putStrLn $ "Changing directory to " ++ projectPath-    inDir True projectPath $ bracket initialize cleanup (const testAction)-    removeDirectoryRecursiveSafe projectPath+------------------------------------------------------------------------------+readTestCase :: (Eq a, Show a, Read a) => a -> Assertion+readTestCase a = assertBool "Read instance failed" $+                 ( ((readsPrec 1) (show a)) == ([(a,"")]))+                 && ((readList ("[" ++ show a ++ "]")) == [([a],"")])+                 && ((R.readPrec_to_S (R.readPrec) 5) (show a) == [(a,"")])+                 && ((R.readPrec_to_S (R.readListPrec) 5) ("[" ++ show a ++ "]")+                     == [([a],"")]) +                 +------------------------------------------------------------------------------+ordTestCase :: (Eq a, Ord a) => a -> a -> Assertion+ordTestCase a b = assertBool "Ord instance failed" $+                  low <= high+                  && (if   low /= high+                      then low < high  && compare low high == LT && high > low+                      else low == high && compare low high == EQ)   where-    ---------------------------------------------------------------------------    fromEnv name def = do-        r <- getEnv name `catch` \(_::SomeException) -> return ""-        if r == "" then return def else return r+    low  = min a b+    high = max a b -    ---------------------------------------------------------------------------    cleanup pHandle = do-        terminateProcess pHandle-        waitForProcess pHandle -    ---------------------------------------------------------------------------    waitABit = threadDelay $ 2*10^(6::Int)+------------------------------------------------------------------------------+eqTestCase :: (Eq a) => a -> a -> Assertion+eqTestCase a b = assertBool "Eq instance failed" $+                 if a == b+                 then (a /= b) == False+                 else (a /= b) == True -    ---------------------------------------------------------------------------    pkgCleanUp d pkg = do-        paths <- globDir1 (compile $ "packages*conf/" ++ pkg ++ "-*") d-        forM_ paths $ \x ->-            rm x `catch` \(_::SomeException) -> return () -      where-        rm x = do-            putStrLn $ "removing " ++ x-            removeFile x+------------------------------------------------------------------------------+genericConfigString :: (MonadSnaplet m, Monad (m b v)) => m b v T.Text+genericConfigString = do+    a <- getSnapletAncestry+    b <- getSnapletFilePath+    c <- getSnapletName+    d <- getSnapletDescription+    e <- getSnapletRootURL+    return $ T.pack $ show (a,b,c,d,e) -    ---------------------------------------------------------------------------    gimmeIfExists p = do-        b <- doesFileExist p-        if b then return (Just p) else return Nothing +------------------------------------------------------------------------------+handlerConfig :: Handler b v ()+handlerConfig = writeText =<< genericConfigString + -------------------------------------------------------------------------------systemOrDie :: String -> IO ()-systemOrDie s = do-    putStrLn $ "Running \"" ++ s ++ "\""-    system s >>= check+shConfigSplice :: SnapletLens (Snaplet b) v -> SnapletISplice b+shConfigSplice _lens = textSplice =<< lift (with' _lens genericConfigString) -  where-    check ExitSuccess = return ()-    check _           = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"
test/suite/TestSuite.hs view
@@ -5,61 +5,69 @@  ------------------------------------------------------------------------------ import           Control.Concurrent-import           Control.Exception-import           Control.Monad-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Char8 as S-import           Network.Http.Client-import           Prelude hiding (catch)-import           Snap.Http.Server.Config-import           Snap.Snaplet+import           Control.Exception                  (SomeException (..), bracket, catch, finally)+import           Control.Monad                      (void)+import           System.Directory                   (getCurrentDirectory, setCurrentDirectory)+import           System.FilePath                    ((</>)) import           System.IO-import           System.Posix.Process-import           System.Posix.Signals-import           System.Posix.Types-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit hiding (Test, path)+ -------------------------------------------------------------------------------import           Blackbox.App import qualified Blackbox.Tests-import           Snap.Http.Server (simpleHttpServe)+import           Prelude                            (Bool (False), IO, Int, Maybe (Nothing), Monad (..), Num (..), flip, return, ($), (.), (^))+import           Snap.Http.Server                   (simpleHttpServe)+import           Snap.Http.Server.Config+import           Snap.Snaplet+import qualified Snap.Snaplet.Auth.Tests+import qualified Snap.Snaplet.Config.Tests+import qualified Snap.Snaplet.Heist.Tests import qualified Snap.Snaplet.Internal.Lensed.Tests import qualified Snap.Snaplet.Internal.LensT.Tests import qualified Snap.Snaplet.Internal.RST.Tests import qualified Snap.Snaplet.Internal.Tests-import qualified Snap.Snaplet.Auth.Tests+import           Snap.Snaplet.Test.Common.App import qualified Snap.Snaplet.Test.Tests-import           Snap.TestCommon+import           Test.Framework  import           SafeCWD - ------------------------------------------------------------------------------ main :: IO () main = do+    -- chdir into test/+    cwd <- getCurrentDirectory+    setCurrentDirectory (cwd </> "test")+     Blackbox.Tests.remove-                "non-cabal-appdir/snaplets/heist/templates/bad.tpl"+                "snaplets/heist/templates/bad.tpl"     Blackbox.Tests.remove-                "non-cabal-appdir/snaplets/heist/templates/good.tpl"-    Blackbox.Tests.removeDir "non-cabal-appdir/snaplets/foosnaplet"+                "snaplets/heist/templates/good.tpl"+ {- Why were we removing this?+    Blackbox.Tests.removeDir "snaplets/foosnaplet"+ -} -    (tid, mvar) <- inDir False "non-cabal-appdir" startServer-    defaultMain [tests] `finally` killThread tid+--    (tid, mvar) <- inDir False "non-cabal-appdir" startServer+    (tid, mvar) <- inDir False "." startServer -    putStrLn "waiting for termination mvar"-    takeMVar mvar+    defaultMain [tests]+      `finally` do+          setCurrentDirectory cwd+          killThread tid+          putStrLn "waiting for termination mvar"+          takeMVar mvar -  where tests = mutuallyExclusive $+      where tests = mutuallyExclusive $                 testGroup "snap" [ internalServerTests                                  , Snap.Snaplet.Auth.Tests.tests                                  , Snap.Snaplet.Test.Tests.tests-                                 , testDefault-                                 , testBarebones-                                 , testTutorial+                                 , Snap.Snaplet.Heist.Tests.heistTests+                                 , Snap.Snaplet.Config.Tests.configTests+                                 , Snap.Snaplet.Internal.RST.Tests.tests+                                 , Snap.Snaplet.Internal.LensT.Tests.tests+                                 , Snap.Snaplet.Internal.Lensed.Tests.tests                                  ]  + ------------------------------------------------------------------------------ internalServerTests :: Test internalServerTests =@@ -77,68 +85,21 @@ startServer :: IO (ThreadId, MVar ()) startServer = do     mvar <- newEmptyMVar-    t    <- forkIO $ serve mvar (setPort 9753 defaultConfig) app+    t    <- forkIOWithUnmask $ \restore ->+            serve restore mvar (setPort 9753 .+                                setBind "127.0.0.1" $ defaultConfig) appInit     threadDelay $ 2*10^(6::Int)     return (t, mvar)    where-    serve mvar config initializer =+    gobble m = void m `catch` \(_::SomeException) -> return ()+    serve restore mvar config initializer =         flip finally (putMVar mvar ()) $-        handle handleErr $ do+        gobble $ restore $ do             hPutStrLn stderr "initializing snaplet"-            (_, handler, doCleanup) <- runSnaplet Nothing initializer--            flip finally doCleanup $ do-                (conf, site) <- combineConfig config handler-                hPutStrLn stderr "bringing up server"-                simpleHttpServe conf site-                hPutStrLn stderr "server killed"--    handleErr :: SomeException -> IO ()-    handleErr e = hPutStrLn stderr $ "startServer exception: " ++ show e----------------------------------------------------------------------------------testBarebones :: Test-testBarebones = testCase "snap/barebones" go-  where-    go = testGeneratedProject "barebonesTest"-                              "barebones"-                              "--force-reinstalls"-                              port-                              testIt-    port = 9990 :: Int-    testIt = do-        body <- get (S.pack $ "http://127.0.0.1:"++(show port)) concatHandler-        assertEqual "server not up" "hello world" body----------------------------------------------------------------------------------testDefault :: Test-testDefault = testCase "snap/default" go-  where-    go = testGeneratedProject "defaultTest"-                              ""-                              "--force-reinstalls"-                              port-                              testIt-    port = 9991 :: Int-    testIt = do-        body <- get (S.pack $ "http://127.0.0.1:"++(show port)) concatHandler-        assertBool "response contains phrase 'Snap Example App Login'"-                   $ "Snap Example App Login" `S.isInfixOf` body----------------------------------------------------------------------------------testTutorial :: Test-testTutorial = testCase "snap/tutorial" go-  where-    go = testGeneratedProject "tutorialTest"-                              "tutorial"-                              "--force-reinstalls"-                              port-                              testIt-    port = 9992 :: Int-    testIt = do-        body <- get (S.pack $ "http://127.0.0.1:"++(show port)++"/hello") concatHandler-        assertEqual "server not up" "hello world" body+            bracket (runSnaplet Nothing initializer)+                    (\(_, _, doCleanup) -> doCleanup)+                    (\(_, handler, _  ) -> do+                         (conf, site) <- combineConfig config handler+                         hPutStrLn stderr "bringing up server"+                         simpleHttpServe conf site)