diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,2 @@ +:set -XOverloadedStrings +:set -isrc diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. - diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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 + + + +## 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) diff --git a/design.md b/design.md new file mode 100644 --- /dev/null +++ b/design.md @@ -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. + diff --git a/haddock.sh b/haddock.sh new file mode 100644 --- /dev/null +++ b/haddock.sh @@ -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/ diff --git a/project_template/barebones/.ghci b/project_template/barebones/.ghci deleted file mode 100644 --- a/project_template/barebones/.ghci +++ /dev/null @@ -1,4 +0,0 @@ -:set -isrc -:set -hide-package MonadCatchIO-mtl -:set -hide-package monads-fd -:set -XOverloadedStrings diff --git a/project_template/barebones/foo.cabal b/project_template/barebones/foo.cabal deleted file mode 100644 --- a/project_template/barebones/foo.cabal +++ /dev/null @@ -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 diff --git a/project_template/barebones/log/access.log b/project_template/barebones/log/access.log deleted file mode 100644 --- a/project_template/barebones/log/access.log +++ /dev/null diff --git a/project_template/barebones/src/Main.hs b/project_template/barebones/src/Main.hs deleted file mode 100644 --- a/project_template/barebones/src/Main.hs +++ /dev/null @@ -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 diff --git a/project_template/default/.ghci b/project_template/default/.ghci deleted file mode 100644 --- a/project_template/default/.ghci +++ /dev/null @@ -1,4 +0,0 @@ -:set -isrc -:set -hide-package MonadCatchIO-mtl -:set -hide-package monads-fd -:set -XOverloadedStrings diff --git a/project_template/default/foo.cabal b/project_template/default/foo.cabal deleted file mode 100644 --- a/project_template/default/foo.cabal +++ /dev/null @@ -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.14, - 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.5, - 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.7 - - 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 diff --git a/project_template/default/log/access.log b/project_template/default/log/access.log deleted file mode 100644 --- a/project_template/default/log/access.log +++ /dev/null diff --git a/project_template/default/log/error.log b/project_template/default/log/error.log deleted file mode 100644 --- a/project_template/default/log/error.log +++ /dev/null diff --git a/project_template/default/snaplets/heist/templates/_login.tpl b/project_template/default/snaplets/heist/templates/_login.tpl deleted file mode 100644 --- a/project_template/default/snaplets/heist/templates/_login.tpl +++ /dev/null @@ -1,9 +0,0 @@ -

Snap Example App Login

- -

- -/login -Login - - -

Don't have a login yet? Create a new user

diff --git a/project_template/default/snaplets/heist/templates/_new_user.tpl b/project_template/default/snaplets/heist/templates/_new_user.tpl deleted file mode 100644 --- a/project_template/default/snaplets/heist/templates/_new_user.tpl +++ /dev/null @@ -1,5 +0,0 @@ -

Register a new user

- -/new_user -Add User - diff --git a/project_template/default/snaplets/heist/templates/base.tpl b/project_template/default/snaplets/heist/templates/base.tpl deleted file mode 100644 --- a/project_template/default/snaplets/heist/templates/base.tpl +++ /dev/null @@ -1,13 +0,0 @@ - - - Snap web server - - - -
- - - -
- - diff --git a/project_template/default/snaplets/heist/templates/index.tpl b/project_template/default/snaplets/heist/templates/index.tpl deleted file mode 100644 --- a/project_template/default/snaplets/heist/templates/index.tpl +++ /dev/null @@ -1,19 +0,0 @@ - - - -

- This is a simple demo page served using - Heist - and the Snap web framework. -

- -

Congrats! You're logged in as ''

- -

Logout

- - - - - - - diff --git a/project_template/default/snaplets/heist/templates/login.tpl b/project_template/default/snaplets/heist/templates/login.tpl deleted file mode 100644 --- a/project_template/default/snaplets/heist/templates/login.tpl +++ /dev/null @@ -1,3 +0,0 @@ - - - diff --git a/project_template/default/snaplets/heist/templates/new_user.tpl b/project_template/default/snaplets/heist/templates/new_user.tpl deleted file mode 100644 --- a/project_template/default/snaplets/heist/templates/new_user.tpl +++ /dev/null @@ -1,3 +0,0 @@ - - - diff --git a/project_template/default/snaplets/heist/templates/userform.tpl b/project_template/default/snaplets/heist/templates/userform.tpl deleted file mode 100644 --- a/project_template/default/snaplets/heist/templates/userform.tpl +++ /dev/null @@ -1,14 +0,0 @@ -
- - - - - - - - - - - -
Login:
Password:
-
diff --git a/project_template/default/src/Application.hs b/project_template/default/src/Application.hs deleted file mode 100644 --- a/project_template/default/src/Application.hs +++ /dev/null @@ -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 - - diff --git a/project_template/default/src/Main.hs b/project_template/default/src/Main.hs deleted file mode 100644 --- a/project_template/default/src/Main.hs +++ /dev/null @@ -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) diff --git a/project_template/default/src/Site.hs b/project_template/default/src/Site.hs deleted file mode 100644 --- a/project_template/default/src/Site.hs +++ /dev/null @@ -1,88 +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 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 noSplices 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 - diff --git a/project_template/default/static/screen.css b/project_template/default/static/screen.css deleted file mode 100644 --- a/project_template/default/static/screen.css +++ /dev/null @@ -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%; -} diff --git a/project_template/tutorial/.ghci b/project_template/tutorial/.ghci deleted file mode 100644 --- a/project_template/tutorial/.ghci +++ /dev/null @@ -1,4 +0,0 @@ -:set -isrc -:set -hide-package MonadCatchIO-mtl -:set -hide-package monads-fd -:set -XOverloadedStrings diff --git a/project_template/tutorial/foo.cabal b/project_template/tutorial/foo.cabal deleted file mode 100644 --- a/project_template/tutorial/foo.cabal +++ /dev/null @@ -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.14, - 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.7 - - if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-unused-do-bind - else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 diff --git a/project_template/tutorial/log/placeholder b/project_template/tutorial/log/placeholder deleted file mode 100644 --- a/project_template/tutorial/log/placeholder +++ /dev/null @@ -1,1 +0,0 @@ -placeholder diff --git a/project_template/tutorial/src/Part2.lhs b/project_template/tutorial/src/Part2.lhs deleted file mode 100644 --- a/project_template/tutorial/src/Part2.lhs +++ /dev/null @@ -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 diff --git a/project_template/tutorial/src/Tutorial.lhs b/project_template/tutorial/src/Tutorial.lhs deleted file mode 100644 --- a/project_template/tutorial/src/Tutorial.lhs +++ /dev/null @@ -1,363 +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.Lens.TH -> import Data.IORef -> import qualified Data.ByteString.Char8 as B -> import Data.Maybe -> import Snap -> import Snap.Snaplet.Heist -> import Part2 - -We start our application by defining a data structure to hold the state. This -data structure includes the state of all snaplets (wrapped in a Snaplet) used -by our application as well as any other state we might want. - -> data App = App -> { _heist :: Snaplet (Heist App) -> , _foo :: Snaplet Foo -> , _bar :: Snaplet Bar -> , _companyName :: IORef B.ByteString -> } -> -> makeLenses ''App - -The field names begin with an underscore because of some more complicated -things going on under the hood. However, all you need to know right now is -that you should prefix things with an underscore and then call `makeLenses`. -This lets you use the names without an underscore in the rest of your -application. - -The next thing we need to do is define an initializer. - -> appInit :: SnapletInit App App -> appInit = makeSnaplet "myapp" "My example application" Nothing $ do -> hs <- nestSnaplet "heist" heist $ heistInit "templates" -> fs <- nestSnaplet "foo" foo $ fooInit -> bs <- nestSnaplet "" bar $ nameSnaplet "newname" $ barInit foo -> addRoutes [ ("/hello", writeText "hello world") -> , ("/fooname", with foo namePage) -> , ("/barname", with bar namePage) -> , ("/company", companyHandler) -> ] -> 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. - diff --git a/runTestsAndCoverage.sh b/runTestsAndCoverage.sh new file mode 100644 --- /dev/null +++ b/runTestsAndCoverage.sh @@ -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 </dev/null 2>&1 + +cat <) or the documentation (). + . + Note: since version 1.0, the \"snap\" executable program for generating + starter projects is provided by the @snap-templates@ package. -license: BSD3 +license: BSD-3-Clause license-file: LICENSE -author: Ozgun Ataman, Doug Beardsley, Gregory Collins, Carl Howells, Chris Smith +author: Ozgun Ataman, Doug Beardsley, + Gregory Collins, Carl Howells, Chris Smith maintainer: snap@snapframework.com build-type: Simple -cabal-version: >= 1.8 homepage: http://snapframework.com/ +bug-reports: https://github.com/snapframework/snap/issues category: Web, Snap +tested-with: + GHC == 8.8.4 + GHC == 8.10.7 + GHC == 9.0.2 + GHC == 9.2.8 + GHC == 9.4.5 + GHC == 9.6.2 + extra-source-files: + .ghci, CONTRIBUTORS, LICENSE, README.md, README.SNAP.md, - project_template/barebones/.ghci, - project_template/barebones/foo.cabal, - project_template/barebones/log/access.log, - project_template/barebones/src/Main.hs, - project_template/default/.ghci, - project_template/default/foo.cabal, - project_template/default/log/access.log, - project_template/default/log/error.log, - project_template/default/static/screen.css, - project_template/default/snaplets/heist/templates/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 @@ -123,13 +128,7 @@ 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 @@ -143,109 +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.9), - attoparsec >= 0.10 && < 0.13, - bytestring >= 0.9.1 && < 0.11, - cereal >= 0.3 && < 0.5, + aeson >= 0.6 && < 2.3, + attoparsec >= 0.10 && < 0.15, + attoparsec-aeson >= 2.1.0.0 && < 3.0, + bytestring >= 0.9.1 && < 0.13, + cereal >= 0.3 && < 0.6, clientsession >= 0.8 && < 0.10, - 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, - 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, + 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, - syb >= 0.1 && < 0.5, - text >= 0.11 && < 1.3, - time >= 1.1 && < 1.5, - 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.11, - 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.7 - - 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.4, - -- 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.10, - text >= 0.11 && < 1.3 +Test-suite testsuite + import: universal + hs-source-dirs: src test/suite + type: exitcode-stdio-1.0 + main-is: TestSuite.hs - extensions: - OverloadedStrings + 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 diff --git a/src/Control/Access/RoleBased/Checker.hs b/src/Control/Access/RoleBased/Checker.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Checker.hs +++ /dev/null @@ -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" diff --git a/src/Control/Access/RoleBased/Internal/Role.hs b/src/Control/Access/RoleBased/Internal/Role.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Internal/Role.hs +++ /dev/null @@ -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] - } diff --git a/src/Control/Access/RoleBased/Internal/RoleMap.hs b/src/Control/Access/RoleBased/Internal/RoleMap.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Internal/RoleMap.hs +++ /dev/null @@ -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 diff --git a/src/Control/Access/RoleBased/Internal/Rule.hs b/src/Control/Access/RoleBased/Internal/Rule.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Internal/Rule.hs +++ /dev/null @@ -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 diff --git a/src/Control/Access/RoleBased/Internal/Types.hs b/src/Control/Access/RoleBased/Internal/Types.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Internal/Types.hs +++ /dev/null @@ -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) - diff --git a/src/Control/Access/RoleBased/Role.hs b/src/Control/Access/RoleBased/Role.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Role.hs +++ /dev/null @@ -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 diff --git a/src/Control/Access/RoleBased/Types.hs b/src/Control/Access/RoleBased/Types.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Types.hs +++ /dev/null @@ -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 diff --git a/src/Snap.hs b/src/Snap.hs --- a/src/Snap.hs +++ b/src/Snap.hs @@ -7,17 +7,11 @@ -} module Snap - ( module Control.Applicative - , module Control.Lens.Loupe - , module Control.Monad.State - , module Snap.Core + ( module Snap.Core , module Snap.Http.Server , module Snap.Snaplet ) where -import Control.Applicative -import Control.Lens.Loupe -import Control.Monad.State import Snap.Core import Snap.Http.Server import Snap.Snaplet diff --git a/src/Snap/Snaplet.hs b/src/Snap/Snaplet.hs --- a/src/Snap/Snaplet.hs +++ b/src/Snap/Snaplet.hs @@ -111,6 +111,7 @@ , runSnaplet , combineConfig , serveSnaplet + , serveSnapletNoArgParsing , loadAppConfig -- * Snaplet Lenses diff --git a/src/Snap/Snaplet/Auth.hs b/src/Snap/Snaplet/Auth.hs --- a/src/Snap/Snaplet/Auth.hs +++ b/src/Snap/Snaplet/Auth.hs @@ -46,7 +46,7 @@ , Role(..) -- * Other Utilities - , authSettingsFromConfig + , authSettingsFromConfig , withBackend , encryptPassword , checkPassword diff --git a/src/Snap/Snaplet/Auth/AuthManager.hs b/src/Snap/Snaplet/Auth/AuthManager.hs --- a/src/Snap/Snaplet/Auth/AuthManager.hs +++ b/src/Snap/Snaplet/Auth/AuthManager.hs @@ -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 - diff --git a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs --- a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs +++ b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs @@ -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 qualified Data.Attoparsec as Atto +import Data.Aeson.Parser (json) +import qualified Data.Attoparsec.ByteString as Atto import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString as B import qualified Data.Map as HM import Data.Map (Map) -import Data.Maybe (fromJust, isJust) +import Data.Maybe (fromJust, isJust, listToMaybe) +import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text as T import Data.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" - - diff --git a/src/Snap/Snaplet/Auth/Handlers.hs b/src/Snap/Snaplet/Auth/Handlers.hs --- a/src/Snap/Snaplet/Auth/Handlers.hs +++ b/src/Snap/Snaplet/Auth/Handlers.hs @@ -11,9 +11,11 @@ ------------------------------------------------------------------------------ import Control.Applicative -import Control.Error +import Control.Monad (join, liftM, liftM2) import Control.Monad.State +import Control.Monad.Trans.Maybe import Data.ByteString (ByteString) +import Data.Maybe import Data.Serialize hiding (get) import Data.Time import Data.Text.Encoding (decodeUtf8) @@ -67,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 @@ -93,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) @@ -114,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 ------------------------------------------------------------------------------ @@ -132,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 } @@ -144,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' @@ -224,7 +230,7 @@ -------------------------------------------------------------------------- updateIp u' = do - ip <- rqRemoteAddr <$> getRequest + ip <- rqClientAddr <$> getRequest return $ u' { userLastLoginIp = userCurrentLoginIp u' , userCurrentLoginIp = Just ip } @@ -319,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 ------------------------------------------------------------------------------ @@ -398,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. @@ -431,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 ------------------------------------------------------------------------------ @@ -497,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_ diff --git a/src/Snap/Snaplet/Auth/SpliceHelpers.hs b/src/Snap/Snaplet/Auth/SpliceHelpers.hs --- a/src/Snap/Snaplet/Auth/SpliceHelpers.hs +++ b/src/Snap/Snaplet/Auth/SpliceHelpers.hs @@ -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 diff --git a/src/Snap/Snaplet/Auth/Types.hs b/src/Snap/Snaplet/Auth/Types.hs --- a/src/Snap/Snaplet/Auth/Types.hs +++ b/src/Snap/Snaplet/Auth/Types.hs @@ -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. diff --git a/src/Snap/Snaplet/Config.hs b/src/Snap/Snaplet/Config.hs --- a/src/Snap/Snaplet/Config.hs +++ b/src/Snap/Snaplet/Config.hs @@ -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 - diff --git a/src/Snap/Snaplet/Heist.hs b/src/Snap/Snaplet/Heist.hs --- a/src/Snap/Snaplet/Heist.hs +++ b/src/Snap/Snaplet/Heist.hs @@ -337,14 +337,13 @@ -- $spliceSection --- As can be seen in the type signature of heistLocal, the internal --- HeistState used by the heist snaplet is parameterized by (Handler b b). --- The reasons for this are beyond the scope of this discussion, but the --- result is that 'lift' inside a splice only works with @Handler b b@ --- actions. When you're writing your own snaplets you obviously would rather --- work with @Handler b v@ so your local snaplet's state is available. We --- provide the SnapletHeist monad to make this possible. The general rule is --- that when you're using Snaplets and Heist, use SnapletHeist instead of --- HeistT (previously called TemplateMonad) and use SnapletISplice instead of --- Splice. +-- The type signature for SnapletHeist uses @(Handler b b)@ as the Heist +-- snaplet's runtime monad. This means that your splices must use the +-- top-level snaplet's @Handler b b@ monad. The reasons for this are beyond +-- the scope of this discussion, but the result is that 'lift' inside a splice +-- only works with @Handler b b@ actions. When you're writing your own +-- snaplets using some snaplet-specific monad @Handler b v@ you still have to +-- use @Handler b b@ for your splices. If the splices need any of the context +-- provided by the @v@, you must pass it in as a parameter to the splice +-- function. diff --git a/src/Snap/Snaplet/Heist/Internal.hs b/src/Snap/Snaplet/Heist/Internal.hs --- a/src/Snap/Snaplet/Heist/Internal.hs +++ b/src/Snap/Snaplet/Heist/Internal.hs @@ -2,9 +2,11 @@ module Snap.Snaplet.Heist.Internal where import Prelude -import Control.Error import Control.Lens +import Control.Monad (liftM) import Control.Monad.State +import qualified Data.ByteString as B +import Data.Char import qualified Data.HashMap.Strict as Map import Data.IORef import Data.List @@ -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 - - diff --git a/src/Snap/Snaplet/HeistNoClass.hs b/src/Snap/Snaplet/HeistNoClass.hs --- a/src/Snap/Snaplet/HeistNoClass.hs +++ b/src/Snap/Snaplet/HeistNoClass.hs @@ -21,7 +21,7 @@ , heistInit' , heistReloader , setInterpreted - , getCurHeistConfig + , getCurHeistConfig , clearHeistCache , addTemplates @@ -63,7 +63,6 @@ import Prelude hiding ((.), id) import Control.Applicative import Control.Category -import Control.Error import Control.Lens import Control.Monad.Reader import Control.Monad.State @@ -72,7 +71,7 @@ import Data.DList (DList) import qualified Data.HashMap.Strict as Map import Data.IORef -import Data.Monoid +import Data.Maybe import qualified Data.Text as T import Data.Text.Encoding import System.FilePath.Posix @@ -81,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 @@ -158,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),())) @@ -195,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" @@ -205,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 @@ -219,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)) @@ -232,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 ------------------------------------------------------------------------------ @@ -477,5 +480,3 @@ -> Handler b v () renderWithSplices heist t splices = renderWithSplices' (subSnaplet heist) t splices - - diff --git a/src/Snap/Snaplet/Internal/Initializer.hs b/src/Snap/Snaplet/Internal/Initializer.hs --- a/src/Snap/Snaplet/Internal/Initializer.hs +++ b/src/Snap/Snaplet/Internal/Initializer.hs @@ -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.Error -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.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 _ _ = [] - + diff --git a/src/Snap/Snaplet/Internal/LensT.hs b/src/Snap/Snaplet/Internal/LensT.hs --- a/src/Snap/Snaplet/Internal/LensT.hs +++ b/src/Snap/Snaplet/Internal/LensT.hs @@ -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.Loupe -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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Internal/Lensed.hs b/src/Snap/Snaplet/Internal/Lensed.hs --- a/src/Snap/Snaplet/Internal/Lensed.hs +++ b/src/Snap/Snaplet/Internal/Lensed.hs @@ -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.Loupe -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 #-} ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Internal/RST.hs b/src/Snap/Snaplet/Internal/RST.hs --- a/src/Snap/Snaplet/Internal/RST.hs +++ b/src/Snap/Snaplet/Internal/RST.hs @@ -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 #-} diff --git a/src/Snap/Snaplet/Internal/Types.hs b/src/Snap/Snaplet/Internal/Types.hs --- a/src/Snap/Snaplet/Internal/Types.hs +++ b/src/Snap/Snaplet/Internal/Types.hs @@ -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.Error -import Control.Lens -import Control.Monad.CatchIO hiding (Handler) -import Control.Monad.Reader -import Control.Monad.State.Class -import Control.Monad.Trans.Writer hiding (pass) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Configurator.Types -import Data.IORef -import Data.Monoid -import Data.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)) - - diff --git a/src/Snap/Snaplet/Session/Backends/CookieSession.hs b/src/Snap/Snaplet/Session/Backends/CookieSession.hs --- a/src/Snap/Snaplet/Session/Backends/CookieSession.hs +++ b/src/Snap/Snaplet/Session/Backends/CookieSession.hs @@ -1,4 +1,5 @@ ------------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,10 +9,9 @@ ) where ------------------------------------------------------------------------------ -import Control.Applicative import Control.Monad.Reader import Data.ByteString (ByteString) -import Data.Generics +import Data.Typeable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import Data.Serialize (Serialize) @@ -20,6 +20,10 @@ import Data.Text.Encoding import Snap.Core (Snap) import Web.ClientSession + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif ------------------------------------------------------------------------------ import Snap.Snaplet import Snap.Snaplet.Session @@ -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 diff --git a/src/Snap/Snaplet/Session/Common.hs b/src/Snap/Snaplet/Session/Common.hs --- a/src/Snap/Snaplet/Session/Common.hs +++ b/src/Snap/Snaplet/Session/Common.hs @@ -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 - - diff --git a/src/Snap/Snaplet/Session/SecureCookie.hs b/src/Snap/Snaplet/Session/SecureCookie.hs --- a/src/Snap/Snaplet/Session/SecureCookie.hs +++ b/src/Snap/Snaplet/Session/SecureCookie.hs @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Test.hs b/src/Snap/Snaplet/Test.hs --- a/src/Snap/Snaplet/Test.hs +++ b/src/Snap/Snaplet/Test.hs @@ -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) diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs deleted file mode 100644 --- a/src/Snap/Starter.hs +++ /dev/null @@ -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 " - , "" - , " 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 diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs deleted file mode 100644 --- a/src/Snap/StarterTH.hs +++ /dev/null @@ -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] diff --git a/test/bad.tpl b/test/bad.tpl new file mode 100644 --- /dev/null +++ b/test/bad.tpl @@ -0,0 +1,1 @@ + diff --git a/test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl b/test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl +++ /dev/null @@ -1,1 +0,0 @@ -baz template page diff --git a/test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl b/test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl +++ /dev/null @@ -1,1 +0,0 @@ -This is an extra template diff --git a/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl b/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl +++ /dev/null @@ -1,1 +0,0 @@ -embedded snaplet page diff --git a/test/non-cabal-appdir/snaplets/heist/templates/index.tpl b/test/non-cabal-appdir/snaplets/heist/templates/index.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/heist/templates/index.tpl +++ /dev/null @@ -1,1 +0,0 @@ -index page diff --git a/test/non-cabal-appdir/snaplets/heist/templates/page.tpl b/test/non-cabal-appdir/snaplets/heist/templates/page.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/heist/templates/page.tpl +++ /dev/null @@ -1,8 +0,0 @@ - - -Example App - - - - - diff --git a/test/non-cabal-appdir/snaplets/heist/templates/session.tpl b/test/non-cabal-appdir/snaplets/heist/templates/session.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/heist/templates/session.tpl +++ /dev/null @@ -1,1 +0,0 @@ - diff --git a/test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl b/test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl +++ /dev/null @@ -1,1 +0,0 @@ -splice page diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh deleted file mode 100644 --- a/test/runTestsAndCoverage.sh +++ /dev/null @@ -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 </dev/null 2>&1 - -cat <= 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.9, - 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.11, - 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.7 - - - 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.9, - 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.11, - 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.7 - - 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.9, - 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.11, - 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.7 - - - 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 - diff --git a/test/snaplets/baz/devel.cfg b/test/snaplets/baz/devel.cfg new file mode 100644 --- /dev/null +++ b/test/snaplets/baz/devel.cfg @@ -0,0 +1,2 @@ +barSnapletField = "barValue" + diff --git a/test/snaplets/baz/templates/bazconfig.tpl b/test/snaplets/baz/templates/bazconfig.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/baz/templates/bazconfig.tpl @@ -0,0 +1,1 @@ +baz config page diff --git a/test/snaplets/baz/templates/bazpage.tpl b/test/snaplets/baz/templates/bazpage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/baz/templates/bazpage.tpl @@ -0,0 +1,1 @@ +baz template page diff --git a/test/snaplets/embedded/extra-templates/extra.tpl b/test/snaplets/embedded/extra-templates/extra.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/embedded/extra-templates/extra.tpl @@ -0,0 +1,1 @@ +This is an extra template diff --git a/test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl b/test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl @@ -0,0 +1,1 @@ +embedded snaplet page diff --git a/test/snaplets/foosnaplet/devel.cfg b/test/snaplets/foosnaplet/devel.cfg new file mode 100644 --- /dev/null +++ b/test/snaplets/foosnaplet/devel.cfg @@ -0,0 +1,2 @@ +fooSnapletField = "fooValue" + diff --git a/test/snaplets/foosnaplet/templates/foopage.tpl b/test/snaplets/foosnaplet/templates/foopage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/foosnaplet/templates/foopage.tpl @@ -0,0 +1,1 @@ +foo template page diff --git a/test/snaplets/heist/templates/_foopage.tpl b/test/snaplets/heist/templates/_foopage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/heist/templates/_foopage.tpl @@ -0,0 +1,7 @@ + + + +

An underscore template.

+ + + diff --git a/test/snaplets/heist/templates/extraTemplates/barpage.tpl b/test/snaplets/heist/templates/extraTemplates/barpage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/heist/templates/extraTemplates/barpage.tpl @@ -0,0 +1,4 @@ + + +Hi. Bar. + diff --git a/test/snaplets/heist/templates/foopage.tpl b/test/snaplets/heist/templates/foopage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/heist/templates/foopage.tpl @@ -0,0 +1,6 @@ + + + Hi. + + + diff --git a/test/snaplets/heist/templates/index.tpl b/test/snaplets/heist/templates/index.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/heist/templates/index.tpl @@ -0,0 +1,1 @@ +index page diff --git a/test/snaplets/heist/templates/page.tpl b/test/snaplets/heist/templates/page.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/heist/templates/page.tpl @@ -0,0 +1,8 @@ + + +Example App + + + + + diff --git a/test/snaplets/heist/templates/session.tpl b/test/snaplets/heist/templates/session.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/heist/templates/session.tpl @@ -0,0 +1,1 @@ + diff --git a/test/snaplets/heist/templates/splicepage.tpl b/test/snaplets/heist/templates/splicepage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/heist/templates/splicepage.tpl @@ -0,0 +1,1 @@ +splice page diff --git a/test/snaplets/heist/templates/userpage.tpl b/test/snaplets/heist/templates/userpage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/heist/templates/userpage.tpl @@ -0,0 +1,50 @@ + + + + + + + +

+ + is logged in + + + + You are not logged in + +

+ +

loggedInUser:

+ +

UserID

+ +

UserLogin

+ +

UserEmail

+ +

UserActive

+ +

UserLoginCount

+ +

UserFailedCount

+ +

UserLoginAt

+ +

UserLastLoginAt

+ +

UserSuspendedAt

+ +

UserLoginIP

+ +

UserLastLoginIP

+ +

UserIfActive

+ +

userIfSuspended

+ + + + + + diff --git a/test/suite/AppMain.hs b/test/suite/AppMain.hs deleted file mode 100644 --- a/test/suite/AppMain.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import Snap.Http.Server.Config -import Snap.Snaplet - -import Blackbox.App - -main :: IO () -main = serveSnaplet defaultConfig app diff --git a/test/suite/Blackbox/App.hs b/test/suite/Blackbox/App.hs deleted file mode 100644 --- a/test/suite/Blackbox/App.hs +++ /dev/null @@ -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" } - diff --git a/test/suite/Blackbox/BarSnaplet.hs b/test/suite/Blackbox/BarSnaplet.hs deleted file mode 100644 --- a/test/suite/Blackbox/BarSnaplet.hs +++ /dev/null @@ -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 - diff --git a/test/suite/Blackbox/Common.hs b/test/suite/Blackbox/Common.hs deleted file mode 100644 --- a/test/suite/Blackbox/Common.hs +++ /dev/null @@ -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) - diff --git a/test/suite/Blackbox/EmbeddedSnaplet.hs b/test/suite/Blackbox/EmbeddedSnaplet.hs deleted file mode 100644 --- a/test/suite/Blackbox/EmbeddedSnaplet.hs +++ /dev/null @@ -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) - diff --git a/test/suite/Blackbox/FooSnaplet.hs b/test/suite/Blackbox/FooSnaplet.hs deleted file mode 100644 --- a/test/suite/Blackbox/FooSnaplet.hs +++ /dev/null @@ -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 - diff --git a/test/suite/Blackbox/Tests.hs b/test/suite/Blackbox/Tests.hs --- a/test/suite/Blackbox/Tests.hs +++ b/test/suite/Blackbox/Tests.hs @@ -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 \n" , requestTest "bazpage4" "baz template page \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 diff --git a/test/suite/Blackbox/Types.hs b/test/suite/Blackbox/Types.hs deleted file mode 100644 --- a/test/suite/Blackbox/Types.hs +++ /dev/null @@ -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 - diff --git a/test/suite/NestTest.hs b/test/suite/NestTest.hs deleted file mode 100644 --- a/test/suite/NestTest.hs +++ /dev/null @@ -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 - diff --git a/test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs b/test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs @@ -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 + diff --git a/test/suite/Snap/Snaplet/Auth/SpliceTests.hs b/test/suite/Snap/Snaplet/Auth/SpliceTests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Auth/SpliceTests.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Auth/Tests.hs b/test/suite/Snap/Snaplet/Auth/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Auth/Tests.hs @@ -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 + ] + diff --git a/test/suite/Snap/Snaplet/Auth/Types/Tests.hs b/test/suite/Snap/Snaplet/Auth/Types/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Auth/Types/Tests.hs @@ -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" + diff --git a/test/suite/Snap/Snaplet/Config/Tests.hs b/test/suite/Snap/Snaplet/Config/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Config/Tests.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Heist/Tests.hs b/test/suite/Snap/Snaplet/Heist/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Heist/Tests.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs b/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs --- a/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Internal/Tests.hs b/test/suite/Snap/Snaplet/Internal/Tests.hs --- a/test/suite/Snap/Snaplet/Internal/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/Tests.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Test/Common/App.hs b/test/suite/Snap/Snaplet/Test/Common/App.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Test/Common/App.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Test/Common/BarSnaplet.hs b/test/suite/Snap/Snaplet/Test/Common/BarSnaplet.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Test/Common/BarSnaplet.hs @@ -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 + diff --git a/test/suite/Snap/Snaplet/Test/Common/EmbeddedSnaplet.hs b/test/suite/Snap/Snaplet/Test/Common/EmbeddedSnaplet.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Test/Common/EmbeddedSnaplet.hs @@ -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) + diff --git a/test/suite/Snap/Snaplet/Test/Common/FooSnaplet.hs b/test/suite/Snap/Snaplet/Test/Common/FooSnaplet.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Test/Common/FooSnaplet.hs @@ -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 + diff --git a/test/suite/Snap/Snaplet/Test/Common/Handlers.hs b/test/suite/Snap/Snaplet/Test/Common/Handlers.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Test/Common/Handlers.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Test/Common/Types.hs b/test/suite/Snap/Snaplet/Test/Common/Types.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Test/Common/Types.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Test/Tests.hs b/test/suite/Snap/Snaplet/Test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Test/Tests.hs @@ -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 diff --git a/test/suite/Snap/TestCommon.hs b/test/suite/Snap/TestCommon.hs --- a/test/suite/Snap/TestCommon.hs +++ b/test/suite/Snap/TestCommon.hs @@ -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 ++ "'" diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -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)