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/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1,8 +1,7 @@ Ozgun Ataman Doug Beardsley Gregory Collins -Shu-yu Guo Carl Howells -Shane O'Brien -James Sanders -Jacob Stanley +Chris Smith +Jurriën Stutterheim +Alfredo Di Napoli diff --git a/README.SNAP.md b/README.SNAP.md --- a/README.SNAP.md +++ b/README.SNAP.md @@ -16,11 +16,11 @@ * a sensible and clean monad for web programming - * an xml-based templating system for generating HTML based on - [expat](http://expat.sourceforge.net/) (via - [hexpat](http://hackage.haskell.org/package/hexpat)) that allows you to - bind Haskell functionality to XML tags without getting PHP-style tag soup - all over your pants + * an xml-based templating system for generating HTML that allows you to bind + Haskell functionality to XML tags without getting PHP-style tag soup all + over your pants + + * a "snaplet" system for building web sites from composable pieces. Snap is currently only officially supported on Unix platforms; it has been tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,62 +1,71 @@ -Snap Framework +Snap Framework [![Hackage Status](https://img.shields.io/hackage/v/snap.svg)](https://hackage.haskell.org/package/snap) ============== -This is the first developer prerelease of the Snap Framework snap -tool. For more information about Snap, read the `README.SNAP.md` or -visit the Snap project website at http://www.snapframework.com/. - -Snap is a nascent web framework for Haskell, based on iteratee I/O (as -[popularized by Oleg -Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). +[![GitHub CI](https://github.com/snapframework/snap/workflows/CI/badge.svg)](https://github.com/snapframework/snap/actions) +Snap is a simple and fast web development framework and server written in +Haskell. For more information about Snap, read the `README.SNAP.md` or visit +the Snap project website at http://www.snapframework.com/. ## Library contents -This is the `snap` executable and supporting library, which contains: - - * a command-line utility for creating initial Snap applications +This is top-level project for the Snap Framework, which contains: * a library allowing Snap applications to recompile actions on the fly in development mode, with no performance loss in production mode. + * a "snaplet" API allowing web applications to be build from composable + pieces. +The command-line utility `snap` for creating initial Snap applications used to +be a part of this package. As of version 1.0, the snap command-line utility is +no longer provided by this package. It is now provided by the package +[`snap-templates`](https://github.com/snapframework/snap-templates). + Building snap ============= -The snap tool and library are built using - [Cabal](http://www.haskell.org/cabal/) and -[Hackage](http://hackage.haskell.org/packages/hackage.html). Just run +After you clone the repository, change to the newly created snap directory and +run + git submodule update --init --recursive + ./init-sandbox.sh cabal install -from the `snap` toplevel directory. - +(You may want to look at pull.sh or pullLatestMaster.sh.) +This updates all the Snap Framework dependencies to the correct version, +creates a sandbox, and installs everything. The snap library is built using +[Cabal](http://www.haskell.org/cabal/) and +[Hackage](http://hackage.haskell.org/packages/hackage.html). ## Building the Haddock Documentation -The haddock documentation can be built using the supplied `haddock.sh` shell -script: - - ./haddock.sh +The haddock documentation can be built using 'cabal haddock'. The docs get put in `dist/doc/html/`. ## Building the testsuite -Snap is still in its very early stages, so most of the "action" (and a big -chunk of the code) right now is centred on the test suite. Snap aims for 100% -test coverage, and we're trying hard to stick to that. - -To build the test suite, `cd` into the `test/` directory and run +To build the test suite, run - $ cabal configure + $ cabal clean + $ cabal configure --enable-tests --enable-library-coverage $ cabal build + $ cabal install --enable-tests From here you can invoke the testsuite by running: $ ./runTestsAndCoverage.sh -The testsuite generates an `hpc` test coverage report in `test/dist/hpc`. +The testsuite generates an `hpc` test coverage report in `dist/hpc`. + + +## Roadmap to Understanding Snaplets + +1. Read `Tutorial.lhs` which is in the `project_template/tutorial/src` directory of the `snap-templates` package. +2. Generate and read the haddock docs. +3. The test code has the nice property that it actually functions as a pretty good example app and covers a lot of the use cases. +4. If you're interested in the implementation, read design.md. 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/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.10, - MonadCatchIO-transformers >= 0.2.1 && < 0.3, - mtl >= 2 && < 3, - snap-core == 0.4.*, - snap-server == 0.4.* - - if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-unused-do-bind - else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 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,21 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Control.Applicative -import Snap.Types -import Snap.Util.FileServe -import Snap.Http.Server - -main :: IO () -main = quickHttpServe $ - ifTop (writeBS "hello world") <|> - route [ ("foo", writeBS "bar") - , ("echo/:echoparam", echoHandler) - ] <|> - dir "static" (serveDirectory ".") - -echoHandler :: Snap () -echoHandler = do - param <- getParam "echoparam" - maybe (writeBS "must specify echo/param in URL") - writeBS param 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,52 +0,0 @@ -Name: projname -Version: 0.1 -Synopsis: Project Synopsis Here -Description: Project Description Here -License: AllRightsReserved -Author: Author -Maintainer: maintainer@example.com -Stability: Experimental -Category: Web -Build-type: Simple -Cabal-version: >=1.2 - -Flag development - Description: Whether to build the server in development (interpreted) mode - Default: False - -Executable projname - hs-source-dirs: src - main-is: Main.hs - - Build-depends: - base >= 4 && < 5, - bytestring >= 0.9.1 && < 0.10, - heist >= 0.5 && < 0.6, - MonadCatchIO-transformers >= 0.2.1 && < 0.3, - mtl >= 2 && < 3, - snap == 0.4.*, - snap-core == 0.4.*, - snap-server == 0.4.*, - text >= 0.11 && < 0.12, - time >= 1.1 && < 1.3, - xmlhtml == 0.1.* - - extensions: TypeSynonymInstances MultiParamTypeClasses - - if flag(development) - cpp-options: -DDEVELOPMENT - build-depends: hint >= 0.3.2 && < 0.4 - -- In development mode, speed is already going to suffer, so skip - -- the fancy optimization flags. Additionally, disable all - -- warnings. The hint library doesn't give an option to execute - -- compiled code when there were also warnings, so disabling - -- warnings allows quicker workflow. - ghc-options: -threaded -w - else - if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-orphans -fno-warn-unused-do-bind - else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-orphans - 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/resources/static/screen.css b/project_template/default/resources/static/screen.css deleted file mode 100644 --- a/project_template/default/resources/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/default/resources/templates/echo.tpl b/project_template/default/resources/templates/echo.tpl deleted file mode 100644 --- a/project_template/default/resources/templates/echo.tpl +++ /dev/null @@ -1,13 +0,0 @@ - - - Echo Page - - -
-

Is there an echo in here?

-
-

You wanted me to say this?

-

""

-

Return

- - diff --git a/project_template/default/resources/templates/index.tpl b/project_template/default/resources/templates/index.tpl deleted file mode 100644 --- a/project_template/default/resources/templates/index.tpl +++ /dev/null @@ -1,32 +0,0 @@ - - - Snap web server - - - -
-

It works!

-

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

-

- Echo test: - cats - dogs - fish -

- - - - - - - - - -
Config generated at:
Page generated at:
-
- - 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,58 +0,0 @@ -{- - -This module defines our application's monad and any application-specific -information it requires. - --} - -module Application - ( Application - , applicationInitializer - ) where - -import Snap.Extension -import Snap.Extension.Heist.Impl -import Snap.Extension.Timer.Impl - - ------------------------------------------------------------------------------- --- | 'Application' is our application's monad. It uses 'SnapExtend' from --- 'Snap.Extension' to provide us with an extended 'MonadSnap' making use of --- the Heist and Timer Snap extensions. -type Application = SnapExtend ApplicationState - - ------------------------------------------------------------------------------- --- | 'ApplicationState' is a record which contains the state needed by the Snap --- extensions we're using. We're using Heist so we can easily render Heist --- templates, and Timer simply to illustrate the config loading differences --- between development and production modes. -data ApplicationState = ApplicationState - { templateState :: HeistState Application - , timerState :: TimerState - } - - ------------------------------------------------------------------------------- -instance HasHeistState Application ApplicationState where - getHeistState = templateState - setHeistState s a = a { templateState = s } - - ------------------------------------------------------------------------------- -instance HasTimerState ApplicationState where - getTimerState = timerState - setTimerState s a = a { timerState = s } - - ------------------------------------------------------------------------------- --- | The 'Initializer' for ApplicationState. For more on 'Initializer's, see --- the documentation from the snap package. Briefly, this is used to --- generate the 'ApplicationState' needed for our application and will --- automatically generate reload\/cleanup actions for us which we don't need --- to worry about. -applicationInitializer :: Initializer ApplicationState -applicationInitializer = do - heist <- heistInitializer "resources/templates" - timer <- timerInitializer - return $ ApplicationState heist timer 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,65 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - -{-| - -This is the entry point for this web server application. It supports -easily switching between interpreting source and running statically -compiled code. - -In either mode, the generated program should be run from the root of -the project tree. When it is run, it locates its templates, static -content, and source files in development mode, relative to the current -working directory. - -When compiled with the development flag, only changes to the -libraries, your cabal file, or this file should require a recompile to -be picked up. Everything else is interpreted at runtime. There are a -few consequences of this. - -First, this is much slower. Running the interpreter takes a -significant chunk of time (a couple tenths of a second on the author's -machine, at this time), regardless of the simplicity of the loaded -code. In order to recompile and re-load server state as infrequently -as possible, the source directories are watched for updates, as are -any extra directories specified below. - -Second, the generated server binary is MUCH larger, since it links in -the GHC API (via the hint library). - -Third, and the reason you would ever want to actually compile with -development mode, is that it enables a faster development cycle. You -can simply edit a file, save your changes, and hit reload to see your -changes reflected immediately. - -When this is compiled without the development flag, all the actions -are statically compiled in. This results in faster execution, a -smaller binary size, and having to recompile the server for any code -change. - --} - -module Main where - -#ifdef DEVELOPMENT -import Snap.Extension.Loader.Devel -import Snap.Http.Server (quickHttpServe) -#else -import Snap.Extension.Server -#endif - -import Application -import Site - -main :: IO () -#ifdef DEVELOPMENT -main = do - -- All source directories will be watched for updates - -- automatically. If any extra directories should be watched for - -- updates, include them here. - snap <- $(let extraWatcheDirs = ["resources/templates"] - in loadSnapTH 'applicationInitializer 'site extraWatcheDirs) - quickHttpServe snap -#else -main = quickHttpServe applicationInitializer site -#endif 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,57 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-| - -This is where all the routes and handlers are defined for your site. The -'site' function combines everything together and is exported by this module. - --} - -module Site - ( site - ) where - -import Control.Applicative -import Data.Maybe -import qualified Data.Text.Encoding as T -import Snap.Extension.Heist -import Snap.Extension.Timer -import Snap.Util.FileServe -import Snap.Types -import Text.Templating.Heist - -import Application - - ------------------------------------------------------------------------------- --- | Renders the front page of the sample site. --- --- The 'ifTop' is required to limit this to the top of a route. --- Otherwise, the way the route table is currently set up, this action --- would be given every request. -index :: Application () -index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index" - where - indexSplices = - [ ("start-time", startTimeSplice) - , ("current-time", currentTimeSplice) - ] - - ------------------------------------------------------------------------------- --- | Renders the echo page. -echo :: Application () -echo = do - message <- decodedParam "stuff" - heistLocal (bindString "message" (T.decodeUtf8 message)) $ render "echo" - where - decodedParam p = fromMaybe "" <$> getParam p - - ------------------------------------------------------------------------------- --- | The main entry point handler. -site :: Application () -site = route [ ("/", index) - , ("/echo/:stuff", echo) - ] - <|> serveDirectory "resources/static" diff --git a/project_template/default/src/Snap/Extension/Timer.hs b/project_template/default/src/Snap/Extension/Timer.hs deleted file mode 100644 --- a/project_template/default/src/Snap/Extension/Timer.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-| - -'Snap.Extension.Timer' exports the 'MonadTimer' interface which allows you to -keep track of the time at which your application was started. The interface's -only operation is 'startTime'. - -Two splices, 'startTimeSplice' and 'currentTimeSplice' are also provided, for -your convenience. - -'Snap.Extension.Timer.Timer' contains the only implementation of this -interface and can be used to turn your application's monad into a -'MonadTimer'. - -More than anything else, this is intended to serve as an example Snap -Extension to any developer wishing to write their own Snap Extension. - --} - -module Snap.Extension.Timer - ( MonadTimer(..) - , startTimeSplice - , currentTimeSplice - ) where - -import Control.Monad.Trans -import Data.Time.Clock -import qualified Data.Text as T -import Snap.Types -import Text.Templating.Heist -import Text.XmlHtml - - ------------------------------------------------------------------------------- --- | The 'MonadTimer' type class. Minimal complete definition: 'startTime'. -class MonadSnap m => MonadTimer m where - -- | The time at which your application was last loaded. - startTime :: m UTCTime - - ------------------------------------------------------------------------------- --- | For your convenience, a splice which shows the start time. -startTimeSplice :: MonadTimer m => Splice m -startTimeSplice = do - time <- lift startTime - return $ [TextNode $ T.pack $ show $ time] - - ------------------------------------------------------------------------------- --- | For your convenience, a splice which shows the current time. -currentTimeSplice :: MonadTimer m => Splice m -currentTimeSplice = do - time <- lift $ liftIO getCurrentTime - return $ [TextNode $ T.pack $ show $ time] diff --git a/project_template/default/src/Snap/Extension/Timer/Impl.hs b/project_template/default/src/Snap/Extension/Timer/Impl.hs deleted file mode 100644 --- a/project_template/default/src/Snap/Extension/Timer/Impl.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-| - -'Snap.Extension.Timer.Impl' is an implementation of the 'MonadTimer' -interface defined in 'Snap.Extension.Timer'. - -As always, to use, add 'TimerState' to your application's state, along with an -instance of 'HasTimerState' for your application's state, making sure to use a -'timerInitializer' in your application's 'Initializer', and then you're ready to go. - -This implementation does not require that your application's monad implement -interfaces from any other Snap Extension. - --} - -module Snap.Extension.Timer.Impl - ( TimerState - , HasTimerState(..) - , timerInitializer - , module Snap.Extension.Timer - ) where - -import Control.Monad.Reader -import Data.Time.Clock -import Snap.Extension -import Snap.Extension.Timer -import Snap.Types - ------------------------------------------------------------------------------- --- | Your application's state must include a 'TimerState' in order for your --- application to be a 'MonadTimer'. -newtype TimerState = TimerState - { _startTime :: UTCTime - } - - ------------------------------------------------------------------------------- --- | For your application's monad to be a 'MonadTimer', your application's --- state needs to be an instance of 'HasTimerState'. Minimal complete --- definition: 'getTimerState', 'setTimerState'. -class HasTimerState s where - getTimerState :: s -> TimerState - setTimerState :: TimerState -> s -> s - - ------------------------------------------------------------------------------- --- | The Initializer for 'TimerState'. No arguments are required. -timerInitializer :: Initializer TimerState -timerInitializer = liftIO getCurrentTime >>= mkInitializer . TimerState - - ------------------------------------------------------------------------------- -instance InitializerState TimerState where - extensionId = const "Timer/Timer" - mkCleanup = const $ return () - mkReload = const $ return () - - ------------------------------------------------------------------------------- -instance HasTimerState s => MonadTimer (SnapExtend s) where - startTime = fmap _startTime $ asks getTimerState - - ------------------------------------------------------------------------------- -instance (MonadSnap m, HasTimerState s) => MonadTimer (ReaderT s m) where - startTime = fmap _startTime $ asks getTimerState 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: BSD-3-Clause license-file: LICENSE -author: James Sanders, Shu-yu Guo, Gregory Collins, Doug Beardsley +author: Ozgun Ataman, Doug Beardsley, + Gregory Collins, Carl Howells, Chris Smith maintainer: snap@snapframework.com build-type: Simple -cabal-version: >= 1.6 homepage: http://snapframework.com/ -category: Web +bug-reports: https://github.com/snapframework/snap/issues +category: Web, Snap +tested-with: + GHC == 8.8.4 + GHC == 8.10.7 + GHC == 9.0.2 + GHC == 9.2.8 + GHC == 9.4.5 + GHC == 9.6.2 + extra-source-files: + .ghci, CONTRIBUTORS, LICENSE, README.md, README.SNAP.md, - project_template/barebones/foo.cabal, - project_template/barebones/src/Main.hs, - project_template/default/foo.cabal, - project_template/default/log/access.log, - project_template/default/log/error.log, - project_template/default/resources/static/screen.css, - project_template/default/resources/templates/echo.tpl, - project_template/default/resources/templates/index.tpl, - project_template/default/src/Application.hs, - project_template/default/src/Main.hs, - project_template/default/src/Site.hs, - project_template/default/src/Snap/Extension/Timer/Impl.hs, - project_template/default/src/Snap/Extension/Timer.hs, + changelog.md, + design.md, extra/hscolour.css, extra/haddock.css, extra/logo.gif, - test/snap-testsuite.cabal, - test/runTests.sh, - test/suite/Snap/TestCommon.hs, - test/suite/TestSuite.hs + haddock.sh, + runTestsAndCoverage.sh, + test/bad.tpl, + test/db.cfg, + test/devel.cfg, + test/good.tpl, + test/snaplets/baz/devel.cfg, + test/snaplets/baz/templates/bazconfig.tpl, + test/snaplets/baz/templates/bazpage.tpl, + test/snaplets/embedded/extra-templates/extra.tpl, + test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl, + test/snaplets/foosnaplet/devel.cfg, + test/snaplets/foosnaplet/templates/foopage.tpl, + test/snaplets/heist/templates/_foopage.tpl, + test/snaplets/heist/templates/extraTemplates/barpage.tpl, + test/snaplets/heist/templates/foopage.tpl, + test/snaplets/heist/templates/index.tpl, + test/snaplets/heist/templates/page.tpl, + test/snaplets/heist/templates/session.tpl, + test/snaplets/heist/templates/splicepage.tpl, + test/snaplets/heist/templates/userpage.tpl +common universal + default-language: Haskell2010 + build-depends: + , base >= 4.5 && < 5 + + if !impl(ghc >= 8.0) + build-depends: + , semigroups >= 0.16 && < 0.19 + , fail >= 4.9 && < 4.10 + + default-extensions: + BangPatterns + CPP + DeriveDataTypeable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + MultiParamTypeClasses + NoMonomorphismRestriction + OverloadedStrings + PackageImports + Rank2Types + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TypeFamilies + TypeOperators + TypeSynonymInstances + Library + import: universal hs-source-dirs: src exposed-modules: - Snap.Extension.Heist, - Snap.Extension.Heist.Impl, - Snap.Extension.Loader.Devel, - Snap.Extension.Server, - Snap.Extension + Snap + Snap.Snaplet + Snap.Snaplet.Heist + Snap.Snaplet.HeistNoClass + Snap.Snaplet.Heist.Compiled + Snap.Snaplet.Heist.Generic + Snap.Snaplet.Heist.Interpreted + Snap.Snaplet.Auth + Snap.Snaplet.Auth.Backends.JsonFile + Snap.Snaplet.Config + Snap.Snaplet.Session + Snap.Snaplet.Session.Common + Snap.Snaplet.Session.SessionManager + Snap.Snaplet.Session.Backends.CookieSession + Snap.Snaplet.Test other-modules: - Snap.Extension.Loader.Devel.Evaluator, - Snap.Extension.Loader.Devel.Signal, - Snap.Extension.Loader.Devel.TreeWatcher + Paths_snap + Snap.Snaplet.Auth.AuthManager + Snap.Snaplet.Auth.Types + Snap.Snaplet.Auth.Handlers + Snap.Snaplet.Auth.SpliceHelpers + Snap.Snaplet.Heist.Internal + Snap.Snaplet.Internal.Initializer + Snap.Snaplet.Internal.LensT + Snap.Snaplet.Internal.Lensed + Snap.Snaplet.Internal.RST + Snap.Snaplet.Internal.Types + Snap.Snaplet.Session.SecureCookie build-depends: - base >= 4 && < 5, - blaze-builder >= 0.2.1.4 && <0.4, - bytestring >= 0.9.1 && < 0.10, - directory >= 1.0 && < 1.2, - enumerator == 0.4.*, - filepath >= 1.1 && <1.3, - MonadCatchIO-transformers >= 0.2.1 && < 0.3, - snap-core == 0.4.*, - heist >= 0.5 && < 0.6, - hint >= 0.3.3.1 && < 0.4, - template-haskell >= 2.3 && < 2.6, - time >= 1.0 && < 1.3 - - if !os(windows) { - build-depends: unix >= 2.2.0.0 && < 2.5 - } + aeson >= 0.6 && < 2.3, + attoparsec >= 0.10 && < 0.15, + attoparsec-aeson >= 2.1.0.0 && < 3.0, + bytestring >= 0.9.1 && < 0.13, + cereal >= 0.3 && < 0.6, + clientsession >= 0.8 && < 0.10, + configurator >= 0.1 && < 0.4, + containers >= 0.2 && < 0.8, + directory >= 1.1 && < 1.4, + directory-tree >= 0.11 && < 0.13, + dlist >= 0.5 && < 1.1, + filepath >= 1.3 && < 1.5, + -- hashable is broken from 1.2.0.0 through 1.2.0.5 + -- snap does work with hashable 1.1.*, but some have complained that + -- the version disjunction causes problems with dependency resolution. + hashable >= 1.2.0.6 && < 1.5, + heist >= 1.1 && < 1.2, + lens >= 3.7.6 && < 5.3, + lifted-base >= 0.2 && < 0.3, + map-syntax >= 0.2 && < 0.4, + monad-control >= 0.3 && < 1.1, + mtl >= 2.0 && < 2.4, + mwc-random >= 0.8 && < 0.16, + pwstore-fast >= 2.2 && < 2.5, + snap-core >= 1.0 && < 1.1, + snap-server >= 1.0 && < 1.2, + stm >= 2.2 && < 2.6, + text >= 1.1.1.0 && < 2.2, + time >= 1.1 && < 1.14, + transformers >= 0.2 && < 0.7, + transformers-base >= 0.4 && < 0.5, + unordered-containers >= 0.1.4 && < 0.3, + xmlhtml >= 0.1 && < 0.3 if impl(ghc >= 6.12.0) - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -fno-warn-unused-do-bind else - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -Executable snap - hs-source-dirs: src - main-is: Snap/Starter.hs +Test-suite testsuite + import: universal + hs-source-dirs: src test/suite + type: exitcode-stdio-1.0 + main-is: TestSuite.hs - other-modules: Snap.StarterTH + autogen-modules: + Paths_snap + other-modules: + Blackbox.Tests + Paths_snap + SafeCWD + Snap + Snap.Snaplet + Snap.Snaplet.Auth + Snap.Snaplet.Auth.AuthManager + Snap.Snaplet.Auth.Backends.JsonFile + Snap.Snaplet.Auth.Handlers + Snap.Snaplet.Auth.Handlers.Tests + Snap.Snaplet.Auth.SpliceHelpers + Snap.Snaplet.Auth.SpliceTests + Snap.Snaplet.Auth.Tests + Snap.Snaplet.Auth.Types + Snap.Snaplet.Auth.Types.Tests + Snap.Snaplet.Test.Common.App + Snap.Snaplet.Test.Common.BarSnaplet + Snap.Snaplet.Test.Common.EmbeddedSnaplet + Snap.Snaplet.Test.Common.FooSnaplet + Snap.Snaplet.Test.Common.Handlers + Snap.Snaplet.Test.Common.Types + Snap.Snaplet.Config + Snap.Snaplet.Config.Tests + Snap.Snaplet.Heist + Snap.Snaplet.Heist.Compiled + Snap.Snaplet.Heist.Generic + Snap.Snaplet.Heist.Internal + Snap.Snaplet.Heist.Interpreted + Snap.Snaplet.Heist.Tests + Snap.Snaplet.HeistNoClass + Snap.Snaplet.Internal.Initializer + Snap.Snaplet.Internal.LensT + Snap.Snaplet.Internal.LensT.Tests + Snap.Snaplet.Internal.Lensed + Snap.Snaplet.Internal.Lensed.Tests + Snap.Snaplet.Internal.RST + Snap.Snaplet.Internal.RST.Tests + Snap.Snaplet.Internal.Tests + Snap.Snaplet.Internal.Types + Snap.Snaplet.Session + Snap.Snaplet.Session.Backends.CookieSession + Snap.Snaplet.Session.Common + Snap.Snaplet.Session.SecureCookie + Snap.Snaplet.Session.SessionManager + Snap.Snaplet.Test + Snap.Snaplet.Test.Tests + Snap.TestCommon + build-depends: - attoparsec >= 0.8.0.2 && < 0.9, - base >= 4 && < 5, + aeson, + async >= 2.0.1.5 && < 2.3, + attoparsec, + attoparsec-aeson, bytestring, - bytestring-nums, - cereal >= 0.3 && < 0.4, + cereal, + clientsession, + configurator, containers, - directory >= 1.0 && < 1.2, + deepseq, + directory, directory-tree, - dlist >= 0.5 && < 0.6, - enumerator == 0.4.*, - filepath >= 1.1 && <1.3, - haskell98, - mtl >= 2, - old-locale, - old-time, - snap-core >= 0.4 && <0.5, - snap-server >= 0.4 && <0.5, - template-haskell >= 2.3 && < 2.6, - text >= 0.11 && <0.12, + dlist, + filepath, + hashable, + heist, + http-streams >= 0.7.1.1 && < 0.9, + HUnit >= 1.2.5.2 && < 1.7, + lens, + lifted-base, + map-syntax, + monad-control, + mtl, + mwc-random, + pwstore-fast, + QuickCheck >= 2.4.2 && < 2.15, + smallcheck >= 1.1.1 && < 1.3, + snap-core, + snap-server, + snap, + stm, + syb, + test-framework >= 0.8.0.3 && < 0.9, + test-framework-hunit >= 0.3.0.1 && < 0.4, + test-framework-quickcheck2 >= 0.3.0.3 && < 0.4, + test-framework-smallcheck >= 0.2 && < 0.3, + text, time, - unix-compat, - zlib - - ghc-prof-options: -prof -auto-all - - if impl(ghc >= 6.12.0) - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-orphans -fno-warn-unused-do-bind - else - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-orphans + transformers, + transformers-base, + unordered-containers, + xmlhtml source-repository head type: git - location: http://git.snapframework.com/snap.git + location: https://github.com/snapframework/snap.git diff --git a/src/Snap.hs b/src/Snap.hs new file mode 100644 --- /dev/null +++ b/src/Snap.hs @@ -0,0 +1,18 @@ +{-| + +This module provides convenience exports of the modules most commonly used +when developing with the Snap Framework. For documentation about Snaplets, +see "Snap.Snaplet". For the core web server API, see "Snap.Core". + +-} + +module Snap + ( module Snap.Core + , module Snap.Http.Server + , module Snap.Snaplet + ) where + +import Snap.Core +import Snap.Http.Server +import Snap.Snaplet + diff --git a/src/Snap/Extension.hs b/src/Snap/Extension.hs deleted file mode 100644 --- a/src/Snap/Extension.hs +++ /dev/null @@ -1,500 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Snap.Extension - ( -- * Introduction - -- $introduction - - -- ** Using Snap Extensions - -- $using - - -- *** Define Application State and Monad - -- $definingtypes - - -- *** Provide Instances For \"HasState\" Classes - -- $hasstateclasses - - -- *** Define The Initializer - -- $initializer - - -- *** Simplified Snap Extension Server - -- $httpserve - - SnapExtend - , Initializer - , InitializerState(..) - , runInitializer - , runInitializerWithReloadAction - , runInitializerWithoutReloadAction - , mkInitializer - , defaultReloadHandler - , nullReloadHandler - ) where - -import Blaze.ByteString.Builder -import Control.Applicative -import Control.Exception (SomeException) -import Control.Monad -import Control.Monad.CatchIO -import Control.Monad.Reader -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Prelude hiding (catch, init) -import Snap.Iteratee (enumBuilder, (>==>)) -import Snap.Types -import System.IO - - -{- $introduction - - Snap Extensions is a library which makes it easy to create reusable plugins - that extend your Snap application with modular chunks of functionality such - as session management, user authentication, templating, or database - connection pooling. - - We achieve this by requiring that you create a datatype that holds an - environment for your application and wrap it around the Snap monad. This new - construct becomes your application's handler monad and gives you access to - your application state throughout your handlers. - - Warning: this interface is still EXPERIMENTAL and has a very high likelihood - of changing substantially in coming versions of Snap. - --} - -{- $using - - Every extension has an interface and at least one implementation of that - interface. - - For some extensions, like Heist, there is only ever going to be one - implementation of the interface. In these cases, both the interface and the - implementation are exported from the same module, Snap.Extension.Heist.Impl. - - Hypothetically, for something like session management though, there could be - multiple implementations, one using a HDBC backend, one using a MongoDB - backend and one just using an encrypted cookie as backend. In these cases, - the interface is exported from Snap.Extension.Session, and the - implementations live in Snap.Extension.Session.HDBC, - Snap.Extension.Session.MongoDB and Snap.Extension.Session.CookieStore. - - Keeping this in mind, there are a number of things you need to do to use - Snap extensions in your application. Let's walk through how to set up a - simple application with the Heist extension turned on. - --} - -{- $definingtypes - - First, we define a record type AppState for holding our application's state, - including the state needed by the extensions we're using. - - At the same time, we also define the monad for our application, App, as - a type alias to @SnapExtend AppState@. 'SnapExtend' is a 'MonadSnap' and - a 'MonadReader', whose environment is a given type; in our case, AppState. - - @ -module App where - -import Database.HDBC -import Database.HDBC.ODBC -import Snap.Extension -import Snap.Extension.Heist -import Snap.Types - -type App = SnapExtend AppState - -data AppState = AppState - { heistState :: HeistState App } - @ - - An important thing to note is that the -State types that we use in the - fields of AppState are specific to each implementation of a extension's - interface. That is, Snap.Extension.Session.HDBC will export a different - SessionState to Snap.Extension.Session.CookieStore, whose internal - representation might be completely different. - - This state is what the extension's implementation needs to be able to do its - job. - --} - -{- $hasstateclasses - - Now we have a datatype that contains all the internal state needed by our - application and the extensions it uses. That's a great start! But when do we - actually get to use this interface and all the functionality that these - extensions export? What is actually being extended? - - We use the interface provided by an extension inside our application's - monad, App. Snap extensions extend our App with new functionality by - allowing us to user their exported functions inside of our handlers. For - example, the Heist extension provides the function: - - @render :: MonadHeist m => ByteString -> m ()@ that renders a template by - its name. - - Is App a 'MonadHeist'? Well, not quite yet. Any 'MonadReader' which is also - a 'MonadSnap' whose environment contains a 'HeistState' is a 'MonadHeist'. - That sounds a lot like our App, doesn't it? We just have to tell the Heist - extension how to find the 'HeistState' in our AppState: - - @ -instance HasHeistState AppState where - getHeistState = heistState - setHeistState hs as = as { heistState = hs } - @ - - Stated another way, if we give our AppState the ability to hold a HeistState - and let the HasHeistState typeclass know how to get/set this state, we are - /automagically/ given the ability to render heist templates in our handlers. - - With these instances, our application's monad App is now a MonadHeist - giving it access to operations like: - - @render :: MonadHeist m => ByteString -> m ()@ - - and - - @heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a@ - --} - -{- $initializer - - So, our monad is now a 'MonadHeist', but how do we actually construct our - AppState and turn an App () into a 'Snap' ()? We need to do this upfront, - once and right before our web server starts listening for connections. - - Snap extensions have a thing called an 'Initializer' that does these things. - Each implementation of a Snap extension interface provides an 'Initializer' - for its -State type. We must construct an initializer type for our -State - type, AppState. An 'Initializer' monad is provided in this library to make - it easy to do this. For your convenience, 'Initializer' is an instance of - 'MonadIO'. - - @ -appInitializer :: Initializer AppState -appInitializer = do - hs <- heistInitializer \"resources/templates\" - return $ AppState hs - @ - - In addition to constructing the AppState, the Initializer monad also - constructs the init, destroy and reload functions for our application from - the init, reload and destroy functions for the extensions. - - Although it won't cause a compile-time error, it is important to get the - order of the initializers correct as much as possible, otherwise they may be - reloaded and destroyed in the wrong order. The "right" order is an order - where every extension's dependencies are initialised before that extension. - For example, Snap.Extension.Session.HDBC would depend on something which - would extend the monad with MonadConnectionPool, i.e., - Snap.Extension.ConnectionPool. If you had this configuration it would be - important that you put the connectionPoolInitializer before the - sessionInitializer in your appInitializer. - - This Initializer AppState can then be passed to 'runInitializer', which - combines our initializer action with our application's handler to produce a - 'Snap' handler (which can be passed to 'httpServe'), a cleanup action (which - you can run after 'httpServe' finishes), and a reload action (which, for - example, you may want to use in your handler for the path \"admin/reload\". - - The following is an example of how you might use this in main: - - @ -main :: IO () -main = do - (snap,cleanup,reload) <- runInitializer appInitializer appSite - let site = snap - <|> path "admin/reload" $ defaultReloadHandler reload cleanup - quickHttpServe site `finally` cleanup - @ - - You'll notice we're using 'defaultReloadHandler'. This is a function - exported by "Snap.Extension" with the type signature - - @MonadSnap m => IO [(ByteString, Maybe ByteString)] -> m ()@ It takes the - reload action returned by 'runInitializer' and returns a 'Snap' action which - renders a simple page showing how the reload went. To avoid denial of - service attacks, the reload handler only works for requests made from the - local host. - --} - -{- $httpserve - - This is, of course, a lot of avoidable boilerplate. Snap extensions framework - comes with another module "Snap.Extension.Server", which provides an - interface mimicking that of "Snap.Http.Server". Their function names clash, - so if you need to use both of them in the same module, use a qualified - import. Using this module, the example above becomes: - - @ -import Snap.Extension.Server - -main :: IO () -main = quickHttpServe appRunner site - @ - - All it needs is a Initializer AppState and an App () and it is ready to go. - You might be wondering what happened to all the reload handler bits we - had before: That stuff has been absorbed into the config for the server. - - One quick note: 'quickHttpServe' doesn't take a config, instead it uses the - defaults augmented with any options specified on the command-line. The - default reload handler path in this case is "admin/reload". - - If you wanted to change this to nullReloadHandler, you would do this: - - @ -import Snap.Extension.Server - -main :: IO () -main = do - config <- commandLineConfig emptyConfig - httpServe (setReloadHandler nullReloadHandler config) appRunner site - @ - - This behaves exactly as the above example apart from the reload handler. - - With this, we now have a fully functional base application that makes use of - the Snap Extensions mechanism. - - To initialize a directory with all of this setup provided as a starting - point, simply @cd@ into the desired location and type: @snap init@. An - example \"Timer\" extension will also be included for your convenience. - --} - ------------------------------------------------------------------------------- --- | A 'SnapExtend' is a 'MonadReader' and a 'MonadSnap' whose environment is --- the application state for a given progam. You would usually type alias --- @SnapExtend AppState@ to something like @App@ to form the monad in which --- you write your application. -newtype SnapExtend s a = SnapExtend (ReaderT s Snap a) - deriving - ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadIO - , MonadCatchIO - , MonadSnap - , MonadReader s - ) - - ------------------------------------------------------------------------------- --- | The 'SCR' datatype is used internally by the 'Initializer' monad to store --- the application's state, cleanup actions and reload actions. -data SCR s = SCR - { _state :: s - -- ^ The internal state of the application's Snap Extensions. - , _cleanup :: IO () - -- ^ IO action which when run will cleanup the application's state, - -- e.g., closing open connections. - , _reload :: IO [(ByteString, Maybe ByteString)] - -- ^ IO action which when run will reload the application's state, e.g., - -- refreshing any cached values stored in the state. - -- - -- It returns a list of tuples whose \"keys\" are the names of the Snap - -- Extensions which were reloaded and whose \"values\" are @Nothing@ - -- when run successfully and @Just x@ on failure, where @x@ is an error - -- message. - } - - ------------------------------------------------------------------------------- --- | The 'Initializer' monad. The code that initialises your application's --- state is written in the 'Initializer' monad. It's used for constructing --- values which have cleanup\/destroy and reload actions associated with them. -newtype Initializer s = Initializer (Bool -> IO (Either s (SCR s))) - - ------------------------------------------------------------------------------- --- | Values of types which are instances of 'InitializerState' have --- cleanup\/destroy and reload actions associated with them. -class InitializerState s where - extensionId :: s -> ByteString - mkCleanup :: s -> IO () - mkReload :: s -> IO () - - ------------------------------------------------------------------------------- --- | Although it has the same type signature, this is not the same as 'return' --- in the 'Initializer' monad. Return simply lifts a value into the --- 'Initializer' monad, but this lifts the value and its destroy\/reload --- actions. Use this when making your own 'Initializer' actions. -mkInitializer :: InitializerState s => s -> Initializer s -mkInitializer s = Initializer $ \v -> setup v $ Right $ mkSCR v - where - handler :: SomeException -> IO (Maybe ByteString) - handler e = return $ Just $ toUTF8 $ show e - maybeCatch m = (m >> return Nothing) `catch` handler - maybeToMsg = maybe " done." $ const " failed." - name = fromUTF8 $ extensionId s - mkSCR v = SCR s (cleanup v) (reload v) - cleanup v = do - when v $ hPutStr stderr $ "Cleaning up " ++ name ++ "..." - m <- maybeCatch $ mkCleanup s - when v $ hPutStrLn stderr $ maybeToMsg m - reload v = do - when v $ hPutStr stderr $ "Reloading " ++ name ++ "..." - m <- maybeCatch $ mkReload s - when v $ hPutStrLn stderr $ maybeToMsg m - return [(extensionId s, m)] - setup v r = do - when v $ hPutStrLn stderr $ "Initializing " ++ name ++ "... done." - return r - - ------------------------------------------------------------------------------- --- | Given the Initializer for your application's state, and a value in the --- monad formed by 'SnapExtend' wrapped it, this returns a 'Snap' action, a --- cleanup action and a reload action. -runInitializer - :: Bool - -- ^ Verbosity; info is printed to 'stderr' when this is 'True' - -> Initializer s - -- ^ The Initializer value - -> SnapExtend s () - -- ^ A web handler in your application's monad - -> IO (Snap (), IO (), IO [(ByteString, Maybe ByteString)]) - -- ^ Returns a 'Snap' handler, a cleanup action, and a reload action. The - -- list returned by the reload action is for error reporting. There is - -- one tuple in the list for each Snap extension; the first element of - -- the tuple is the name of the Snap extension, and the second is a Maybe - -- which contains Nothing if there was no error reloading that extension - -- and a Just with the ByteString containing the error message if there - -- was. -runInitializer v (Initializer r) (SnapExtend m) = - r v >>= \e -> case e of - Left s -> return (runReaderT m s, return (), return []) - Right (SCR s a b) -> return (runReaderT m s, a, b) - - ------------------------------------------------------------------------------- --- | Serves the same purpose as 'runInitializer', but combines the --- application's web handler with a user-supplied action to be run to reload --- the application's state. -runInitializerWithReloadAction - :: Bool - -- ^ Verbosity; info is printed to 'stderr' when this is 'True' - -> Initializer s - -- ^ The Initializer value - -> SnapExtend s () - -- ^ A web handler in your application's monad. - -> (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ()) - -- ^ Your desired \"reload\" handler; it gets passed the reload - -- action. This handler is always run, so you have to guard the path - -- yourself (with. - -> IO (Snap (), IO ()) - -- ^ Your 'Snap' handler and a cleanup action. -runInitializerWithReloadAction v (Initializer r) se f = do - (state, cleanup, reload) <- runInit - - let (SnapExtend m') = f reload <|> se - return (runReaderT m' state, cleanup) - - where - runInit = r v >>= \e -> - case e of - Left s -> return (s, return (), return []) - Right (SCR s a b) -> return (s, a, b) - ------------------------------------------------------------------------------- --- | A cut-down version of 'runInitializer', for use by the hint --- loading code -runInitializerWithoutReloadAction :: Initializer s - -- ^ The Initializer value - -> SnapExtend s () - -- ^ An action in your application's monad. - -> IO (Snap (), IO ()) -runInitializerWithoutReloadAction i se = do - (action, cleanup, _) <- runInitializer True i se - return (action, cleanup) - - ------------------------------------------------------------------------------- -instance Functor Initializer where - fmap f (Initializer r) = Initializer $ \v -> r v >>= \e -> return $ - case e of - Left s -> Left $ f s - Right (SCR s a b) -> Right $ SCR (f s) a b - - ------------------------------------------------------------------------------- -instance Applicative Initializer where - pure = return - (<*>) = ap - - ------------------------------------------------------------------------------- -instance Monad Initializer where - return = Initializer . const . return . Left - a >>= f = join' $ fmap f a - - ------------------------------------------------------------------------------- -instance MonadIO Initializer where - liftIO = Initializer . const . fmap Left - - ------------------------------------------------------------------------------- --- | Join for the 'Initializer' monad. This is used in the definition of bind --- for the 'Initializer' monad. -join' :: Initializer (Initializer s) -> Initializer s -join' (Initializer r) = Initializer $ \v -> r v >>= \e -> case e of - Left (Initializer r') -> r' v - Right (SCR (Initializer r') a b) -> r' v >>= \e' -> return $ Right $ - case e' of - Left s -> SCR s a b - Right (SCR s a' b') -> SCR s (a' >> a) (liftM2 (++) b b') - - ------------------------------------------------------------------------------- --- | This takes the last value of the tuple returned by 'runInitializer', --- which is a list representing the results of an attempt to reload the --- application's Snap Extensions, and turns it into a Snap action which --- displays the these results. -defaultReloadHandler :: MonadSnap m - => IO [(ByteString, Maybe ByteString)] - -> m () -defaultReloadHandler ioms = failIfNotLocal $ do - ms <- liftIO $ ioms - let showE e = mappend "Error: " $ toUTF8 $ show e - format (n, m) = mconcat [n, ": ", maybe "Success" showE m, "\n"] - msg = mconcat $ map format ms - finishWith $ setContentType "text/plain; charset=utf-8" - $ setContentLength (fromIntegral $ B.length msg) - $ modifyResponseBody (>==> enumBuilder (fromByteString msg)) - emptyResponse - where - failIfNotLocal m = do - rip <- liftM rqRemoteAddr getRequest - if not $ elem rip [ "127.0.0.1" - , "localhost" - , "::1" ] - then pass - else m - ------------------------------------------------------------------------------- --- | Use this reload handler to disable the ability to have a web handler --- which reloads Snap extensions. -nullReloadHandler :: MonadSnap m - => IO [(ByteString, Maybe ByteString)] - -> m () -nullReloadHandler = const pass - - ------------------------------------------------------------------------------- -fromUTF8 :: ByteString -> String -fromUTF8 = T.unpack . T.decodeUtf8 - -toUTF8 :: String -> ByteString -toUTF8 = T.encodeUtf8 . T.pack diff --git a/src/Snap/Extension/Heist.hs b/src/Snap/Extension/Heist.hs deleted file mode 100644 --- a/src/Snap/Extension/Heist.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -{-| - -'Snap.Extension.Heist' exports the 'MonadHeist' interface which allows you to -integrate Heist templates into your Snap application. The interface's -operations are 'heistServe', 'heistServeSingle', 'heistLocal' and 'render'. As -a convenience, we also provide 'renderWithSplices' that combines 'heistLocal' -and 'render' into a single function call. - -'Snap.Extension.Heist.Impl' contains the only implementation of this interface -and can be used to turn your application's monad into a 'MonadHeist'. - -'MonadHeist' is unusual among Snap extensions in that it's a multi-parameter -typeclass. The last parameter is your application's monad, and the first is -the monad you want the 'TemplateState' to use. This is usually, but not -always, also your application's monad. - -This module should not be used directly. Instead, import -"Snap.Extension.Heist.Impl" in your application. - --} - -module Snap.Extension.Heist - ( MonadHeist(..) - , renderWithSplices ) where - -import Control.Applicative -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Text (Text) -import Snap.Types -import Snap.Util.FileServe -import Text.Templating.Heist - - ------------------------------------------------------------------------------- --- | The 'MonadHeist' type class. Minimal complete definition: 'render', --- 'heistLocal'. -class (Monad n, MonadSnap m) => MonadHeist n m | m -> n where - -- | Renders a template as text\/html. If the given template is not found, - -- this returns 'empty'. - render :: ByteString -> m () - - -- | Renders a template as the given content type. If the given template - -- is not found, this returns 'empty'. - renderAs :: ByteString -> ByteString -> m () - - -- | Runs an action with a modified 'TemplateState'. You might want to use - -- this if you had a set of splices which were customised for a specific - -- action. To do that you would do: - -- - -- > heistLocal (bindSplices mySplices) $ render "myTemplate" - heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a - - -- | Analogous to 'fileServe'. If the template specified in the request - -- path is not found, it returns 'empty'. - heistServe :: m () - heistServe = ifTop (render "index") <|> (render . B.pack =<< getSafePath) - - -- | Analogous to 'fileServeSingle'. If the given template is not found, - -- this throws an error. - heistServeSingle :: ByteString -> m () - heistServeSingle t = render t - <|> error ("Template " ++ show t ++ " not found.") - - ------------------------------------------------------------------------------- --- | Helper function for common use case: --- Render a template with a given set of splices. -renderWithSplices - :: (MonadHeist n m) - => ByteString -- ^ Template to render - -> [(Text, Splice n)] -- ^ Splice mapping - -> m () -renderWithSplices t sps = heistLocal bsps $ render t - where bsps = bindSplices sps diff --git a/src/Snap/Extension/Heist/Impl.hs b/src/Snap/Extension/Heist/Impl.hs deleted file mode 100644 --- a/src/Snap/Extension/Heist/Impl.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -{-| - -'Snap.Extension.Heist.Impl' is an implementation of the 'MonadHeist' -interface defined in 'Snap.Extension.Heist'. - -As always, to use, add 'HeistState' to your application's state, along with an -instance of 'HasHeistState' for your application's state, making sure to -use a 'heistInitializer' in your application's 'Initializer', and then you're -ready to go. - -'Snap.Extension.Heist.Impl' is a little different to other Snap Extensions, -which is unfortunate as it is probably the most widely useful one. As -explained below, 'HeistState' takes your application's monad as a type -argument, and 'HasHeistState' is a multi-parameter type class, the additional -first parameter also being your application's monad. - -Two instances of 'MonadHeist' are provided with this module. One is designed -for users wanting to use Heist templates with their application, the other is -designed for users writing Snap Extensions which use their own Heist templates -internally. - -The first one of these instances is -@HasHeistState (SnapExtend s) s => MonadHeist (SnapExtend s) (SnapExtend s)@. -This means that any type @s@ which has a 'HeistState', whose -'TemplateState'\'s monad is @SnapExtend s@ forms a 'MonadHeist' whose -'TemplateState'\'s monad is @SnapExtend s@ and whose monad itself is -@SnapExtend s@. The @s@ here is your application's state, and @SnapExtend s@ -is your application's monad. - -The second one of these instances is -@HasHeistState m s => MonadHeist m (ReaderT s m)@. This means that any type -@s@ which has, for any m, a @HeistState m@, forms a 'MonadHeist', whose -'TemplateState'\'s monad is @m@, when made the environment of -a 'ReaderT' wrapped around @m@. The @s@ here would be the Snap Extension's -internal state, and the @m@ would be 'SnapExtend' wrapped around any @s'@ -which was an instance of the Snap Extension's @HasState@ class. - -This implementation does not require that your application's monad implement -interfaces from any other Snap Extension. - --} - -module Snap.Extension.Heist.Impl - ( - - -- * Heist State Definitions - HeistState - , HasHeistState(..) - , heistInitializer - - -- * The MonadHeist Interface - , MonadHeist(..) - - -- * Convenience Functions - , registerSplices - ) where - -import Control.Concurrent.MVar -import Control.Monad.Reader -import Data.ByteString (ByteString) -import Data.Maybe -import Data.Text (Text) -import Snap.Extension -import Snap.Extension.Heist -import Snap.Types -import Text.Templating.Heist -import Text.Templating.Heist.Splices.Static - - ------------------------------------------------------------------------------- --- | Your application's state must include a 'HeistState' in order for your --- application to be a 'MonadHeist'. --- --- Unlike other @-State@ types, this is of kind @(* -> *) -> *@. Unless you're --- developing your own Snap Extension which has its own internal 'HeistState', --- the type argument you want to pass to 'HeistState' is your application's --- monad, which should be 'SnapExtend' wrapped around your application's --- state. -data MonadSnap m => HeistState m = HeistState - { _path :: FilePath - , _origTs :: TemplateState m - , _tsMVar :: MVar (TemplateState m) - , _sts :: StaticTagState - , _modifier :: TemplateState m -> TemplateState m - } - - ------------------------------------------------------------------------------- --- | For your application's monad to be a 'MonadHeist', your application's --- state needs to be an instance of 'HasHeistState'. Minimal complete --- definition: 'getHeistState', 'setHeistState'. --- --- Unlike other @HasState@ type classes, this is a type class has two --- parameters. Among other things, this means that you will need to enable the --- @FlexibleInstances@ and @MultiParameterTypeClasses@ language extensions to --- be able to create an instance of @HasHeistState@. In most cases, the last --- parameter will as usual be your application's state, and the additional --- first one will be the monad formed by wrapping 'SnapExtend' around your --- application's state. --- --- However, if you are developing your own Snap Extension which uses its own --- internal 'HeistState', the last parameter will be your Snap Extension's --- internal state, and the additional first parameter will be any monad formed --- by wrapping @SnapExtend@ around a type which has an instance of the --- @HasState@ class for your monad. These two use cases are subtly different, --- which is why 'HasHeistState' needs two type parameters. -class MonadSnap m => HasHeistState m s | s -> m where - getHeistState :: s -> HeistState m - setHeistState :: HeistState m -> s -> s - - modifyHeistState :: (HeistState m -> HeistState m) -> s -> s - modifyHeistState f s = setHeistState (f $ getHeistState s) s - - ------------------------------------------------------------------------------- --- | The 'Initializer' for 'HeistState'. It takes one argument, a path to a --- template directory containing @.tpl@ files. -heistInitializer :: MonadSnap m => FilePath -> Initializer (HeistState m) -heistInitializer p = do - heistState <- liftIO $ do - (origTs,sts) <- bindStaticTag $ emptyTemplateState p - loadTemplates p origTs >>= either error (\ts -> do - tsMVar <- newMVar ts - return $ HeistState p origTs tsMVar sts id) - mkInitializer heistState - - ------------------------------------------------------------------------------- -instance MonadSnap m => InitializerState (HeistState m) where - extensionId = const "Heist/Impl" - mkCleanup = const $ return () - mkReload (HeistState p origTs tsMVar sts _) = do - clearStaticTagCache $ sts - either error (modifyMVar_ tsMVar . const . return) =<< - loadTemplates p origTs - - ------------------------------------------------------------------------------- -instance HasHeistState (SnapExtend s) s - => MonadHeist (SnapExtend s) (SnapExtend s) where - render t = do - hs <- asks getHeistState - renderHelper hs Nothing t - - renderAs c t = do - hs <- asks getHeistState - renderHelper hs (Just c) t - - heistLocal f = local $ modifyHeistState $ \s -> - s { _modifier = f . _modifier s } - - ------------------------------------------------------------------------------- -instance HasHeistState m s => MonadHeist m (ReaderT s m) where - render t = ReaderT $ \s -> renderHelper (getHeistState s) Nothing t - - renderAs c t = ReaderT $ \s -> renderHelper (getHeistState s) (Just c) t - - heistLocal f = local $ modifyHeistState $ \s -> - s { _modifier = f . _modifier s } - - ------------------------------------------------------------------------------- -renderHelper :: (MonadSnap m) - => HeistState m - -> Maybe MIMEType - -> ByteString - -> m () -renderHelper hs c t = do - let (HeistState _ _ tsMVar _ modifier) = hs - ts <- liftIO $ fmap modifier $ readMVar tsMVar - renderTemplate ts t >>= maybe pass (\(b,mime) -> do - modifyResponse $ setContentType $ fromMaybe mime c - writeBuilder b) - - ------------------------------------------------------------------------------- --- | Take your application's state and register these splices in it so --- that you don't have to re-list them in every handler. Should be called from --- inside your application's 'Initializer'. --- --- Typical use cases are dynamically generated components that are present in --- many of your views. --- --- Example Usage: --- --- @ --- appInit :: Initializer AppState --- appInit = do --- hs <- heistInitializer \"templates\" --- registerSplices hs $ --- [ (\"tabs\", tabsSplice) --- , (\"loginLogout\", loginLogoutSplice) ] --- @ -registerSplices - :: (MonadSnap m, MonadIO n) - => HeistState m - -- ^ Heist state that you are going to embed in your application's state. - -> [(Text, Splice m)] - -- ^ Your splices. - -> n () -registerSplices s sps = liftIO $ do - let mv = _tsMVar s - modifyMVar_ mv $ (return . bindSplices sps) diff --git a/src/Snap/Extension/Loader/Devel.hs b/src/Snap/Extension/Loader/Devel.hs deleted file mode 100644 --- a/src/Snap/Extension/Loader/Devel.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} --- | This module includes the machinery necessary to use hint to load --- action code dynamically. It includes a Template Haskell function --- to gather the necessary compile-time information about code --- location, compiler arguments, etc, and bind that information into --- the calls to the dynamic loader. -module Snap.Extension.Loader.Devel - ( loadSnapTH - ) where - -import Control.Monad (liftM2) - -import Data.List -import Data.Maybe (catMaybes) -import Data.Time.Clock (diffUTCTime, getCurrentTime) - -import Language.Haskell.Interpreter hiding (lift, liftIO) -import Language.Haskell.Interpreter.Unsafe - -import Language.Haskell.TH - -import System.Environment (getArgs) - ------------------------------------------------------------------------------- -import Snap.Types -import Snap.Extension (runInitializerWithoutReloadAction) -import Snap.Extension.Loader.Devel.Signal -import Snap.Extension.Loader.Devel.Evaluator -import Snap.Extension.Loader.Devel.TreeWatcher - ------------------------------------------------------------------------------- --- | This function derives all the information necessary to use the --- interpreter from the compile-time environment, and compiles it in --- to the generated code. --- --- This could be considered a TH wrapper around a function --- --- > loadSnap :: Initializer s -> SnapExtend s () -> [String] -> IO (Snap ()) --- --- with a magical implementation. --- --- The upshot is that you shouldn't need to recompile your server --- during development unless your .cabal file changes, or the code --- that uses this splice changes. -loadSnapTH :: Name -> Name -> [String] -> Q Exp -loadSnapTH initializer action additionalWatchDirs = do - args <- runIO getArgs - - let initMod = nameModule initializer - initBase = nameBase initializer - actMod = nameModule action - actBase = nameBase action - - opts = getHintOpts args - modules = catMaybes [initMod, actMod] - srcPaths = additionalWatchDirs ++ getSrcPaths args - - -- The let in this block causes an extra static type check that the - -- types of the names passed in were correct at compile time. - [| let _ = runInitializerWithoutReloadAction $(varE initializer) - $(varE action) - in hintSnap opts modules srcPaths initBase actBase |] - - ------------------------------------------------------------------------------- --- | Convert the command-line arguments passed in to options for the --- hint interpreter. This is somewhat brittle code, based on a few --- experimental datapoints regarding the structure of the command-line --- arguments cabal produces. -getHintOpts :: [String] -> [String] -getHintOpts args = removeBad opts - where - bad = ["-threaded", "-O"] - removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad) - - hideAll = filter (== "-hide-all-packages") args - - srcOpts = filter (\x -> "-i" `isPrefixOf` x - && not ("-idist" `isPrefixOf` x)) args - - toCopy = filter (not . isSuffixOf ".hs") $ - dropWhile (not . ("-package" `isPrefixOf`)) args - copy = map (intercalate " ") . groupBy (\_ s -> not $ "-" `isPrefixOf` s) - - opts = hideAll ++ srcOpts ++ copy toCopy - - ------------------------------------------------------------------------------- --- | This function extracts the source paths from the compilation args -getSrcPaths :: [String] -> [String] -getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg - where - srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x) - - ------------------------------------------------------------------------------- --- | This function creates the Snap handler that actually is --- responsible for doing the dynamic loading of actions via hint, --- given all of the configuration information that the interpreter --- needs. It also ensures safe concurrent access to the interpreter, --- and caches the interpreter results for a short time before allowing --- it to run again. --- --- Generally, this won't be called manually. Instead, loadSnapTH will --- generate a call to it at compile-time, calculating all the --- arguments from its environment. -hintSnap :: [String] -- ^ A list of command-line options for the interpreter - -> [String] -- ^ A list of modules that need to be - -- interpreted. This should contain only the - -- modules which contain the initialization, - -- cleanup, and handler actions. Everything else - -- they require will be loaded transitively. - -> [String] -- ^ A list of paths to watch for updates - -> String -- ^ The name of the initializer action - -> String -- ^ The name of the SnapExtend action - -> IO (Snap ()) -hintSnap opts modules srcPaths initialization handler = - protectedHintEvaluator initialize test loader - where - action = intercalate " " [ "runInitializerWithoutReloadAction" - , initialization - , handler - ] - interpreter = do - loadModules . nub $ modules - let imports = "Prelude" : - "Snap.Extension" : - "Snap.Types" : - modules - setImports . nub $ imports - - interpret action (as :: HintLoadable) - - loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter - - formatOnError (Left err) = error $ format err - formatOnError (Right a) = a - - loader = formatOnError `fmap` protectHandlers loadInterpreter - - initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths - - test (prevTime, ts) = do - now <- getCurrentTime - if diffUTCTime now prevTime < 3 - then return True - else checkTreeStatus ts - - ------------------------------------------------------------------------------- --- | Convert an InterpreterError to a String for presentation -format :: InterpreterError -> String -format (UnknownError e) = "Unknown interpreter error:\r\n\r\n" ++ e -format (NotAllowed e) = "Interpreter action not allowed:\r\n\r\n" ++ e -format (GhcException e) = "GHC error:\r\n\r\n" ++ e -format (WontCompile errs) = "Compile errors:\r\n\r\n" ++ - (intercalate "\r\n" $ nub $ map errMsg errs) - diff --git a/src/Snap/Extension/Loader/Devel/Evaluator.hs b/src/Snap/Extension/Loader/Devel/Evaluator.hs deleted file mode 100644 --- a/src/Snap/Extension/Loader/Devel/Evaluator.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Snap.Extension.Loader.Devel.Evaluator - ( HintLoadable - , protectedHintEvaluator - ) where - - -import Control.Exception -import Control.Monad (when) -import Control.Monad.Trans (liftIO) - -import Control.Concurrent (ThreadId, forkIO, myThreadId) -import Control.Concurrent.MVar - -import Prelude hiding (catch, init, any) - -import Snap.Types (Snap) - - ------------------------------------------------------------------------------- --- | A type synonym to simply talking about the type loaded by hint. -type HintLoadable = IO (Snap (), IO ()) - - ------------------------------------------------------------------------------- --- | Convert an action to generate 'HintLoadable's into an action to --- generate Snap actions. The resulting action will share initialized --- state until the next execution of the input action. At this time, --- the cleanup action will be executed. --- --- The first two arguments control when recompiles are done. The --- first argument is an action that is executed when compilation --- starts. The second is a function from the result of the first --- action to an action that determines whether the value from the --- previous compilation is still good. This abstracts out the --- strategy for determining when a cached result is no longer valid. --- --- If an exception is raised during the processing of the action, it --- will be thrown to all waiting threads, and for all requests made --- before the recompile condition is reached. -protectedHintEvaluator :: forall a. - IO a - -> (a -> IO Bool) - -> IO HintLoadable - -> IO (Snap ()) -protectedHintEvaluator start test getInternals = do - -- The list of requesters waiting for a result. Contains the - -- ThreadId in case of exceptions, and an empty MVar awaiting a - -- successful result. - readerContainer <- newReaderContainer - - -- Contains the previous result and initialization value, and the - -- time it was stored, if a previous result has been computed. - -- The result stored is either the actual result and - -- initialization result, or the exception thrown by the - -- calculation. - resultContainer <- newResultContainer - - -- The model used for the above MVars in the returned action is - -- "keep them full, unless updating them." In every case, when - -- one of those MVars is emptied, the next action is to fill that - -- same MVar. This makes deadlocking on MVar wait impossible. - return $ do - let waitForNewResult :: IO (Snap ()) - waitForNewResult = do - -- Need to calculate a new result - tid <- myThreadId - reader <- newEmptyMVar - - readers <- takeMVar readerContainer - - -- Some strictness is employed to ensure the MVar - -- isn't holding on to a chain of unevaluated thunks. - let pair = (tid, reader) - newReaders = readers `seq` pair `seq` (pair : readers) - putMVar readerContainer $! newReaders - - -- If this is the first reader to queue, clean up the - -- previous state, if there was any, and then begin - -- evaluation of the new code and state. - when (null readers) $ do - let runAndFill = block $ do - -- run the cleanup action - previous <- readMVar resultContainer - unblock $ cleanup previous - - -- compile the new internals and initialize - stateInitializer <- unblock getInternals - res <- unblock stateInitializer - - let a = fst res - - clearAndNotify (Right res) (flip putMVar a . snd) - - killWaiting :: SomeException -> IO () - killWaiting e = block $ do - clearAndNotify (Left e) (flip throwTo e . fst) - throwIO e - - clearAndNotify r f = do - a <- unblock start - _ <- swapMVar resultContainer $ Just (r, a) - allReaders <- swapMVar readerContainer [] - mapM_ f allReaders - - _ <- forkIO $ runAndFill `catch` killWaiting - return () - - -- Wait for the evaluation of the action to complete, - -- and return its result. - takeMVar reader - - existingResult <- liftIO $ readMVar resultContainer - - getResult <- liftIO $ case existingResult of - Just (res, a) -> do - -- There's an existing result. Check for validity - valid <- test a - case (valid, res) of - (True, Right (x, _)) -> return x - (True, Left e) -> throwIO e - (False, _) -> do - _ <- swapMVar resultContainer Nothing - waitForNewResult - Nothing -> waitForNewResult - getResult - where - newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))]) - newReaderContainer = newMVar [] - - newResultContainer :: IO (MVar (Maybe (Either SomeException - (Snap (), IO ()), a))) - newResultContainer = newMVar Nothing - - cleanup (Just (Right (_, clean), _)) = clean - cleanup _ = return () diff --git a/src/Snap/Extension/Loader/Devel/Signal.hs b/src/Snap/Extension/Loader/Devel/Signal.hs deleted file mode 100644 --- a/src/Snap/Extension/Loader/Devel/Signal.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE CPP #-} -module Snap.Extension.Loader.Devel.Signal (protectHandlers) where - -import Control.Exception (bracket) - -#ifdef mingw32_HOST_OS -import GHC.ConsoleHandler as C - - -saveHandlers :: IO C.Handler -saveHandlers = C.installHandler Ignore - - -restoreHandlers :: C.Handler -> IO C.Handler -restoreHandlers = C.installHandler - - -#else -import qualified System.Posix.Signals as S - -helper :: S.Handler -> S.Signal -> IO S.Handler -helper handler signal = S.installHandler signal handler Nothing - - -signals :: [S.Signal] -signals = [ S.sigQUIT - , S.sigINT - , S.sigHUP - , S.sigTERM - ] - - -saveHandlers :: IO [S.Handler] -saveHandlers = mapM (helper S.Ignore) signals - - -restoreHandlers :: [S.Handler] -> IO [S.Handler] -restoreHandlers h = sequence $ zipWith helper h signals - - -#endif -protectHandlers :: IO a -> IO a -protectHandlers a = bracket saveHandlers restoreHandlers $ const a diff --git a/src/Snap/Extension/Loader/Devel/TreeWatcher.hs b/src/Snap/Extension/Loader/Devel/TreeWatcher.hs deleted file mode 100644 --- a/src/Snap/Extension/Loader/Devel/TreeWatcher.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Snap.Extension.Loader.Devel.TreeWatcher - ( TreeStatus - , getTreeStatus - , checkTreeStatus - ) where - -import Control.Applicative - -import System.Directory -import System.Directory.Tree - -import System.Time - - ------------------------------------------------------------------------------- --- | An opaque representation of the contents and last modification --- times of a forest of directory trees. -data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime] - - ------------------------------------------------------------------------------- --- | Create a 'TreeStatus' for later checking with 'checkTreeStatus' -getTreeStatus :: [FilePath] -> IO TreeStatus -getTreeStatus = liftA2 (<$>) TS readModificationTimes - - ------------------------------------------------------------------------------- --- | Checks that all the files present in the initial set of paths are --- the exact set of files currently present, with unchanged modifcations times -checkTreeStatus :: TreeStatus -> IO Bool -checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths - where - check = and . zipWith adtEq entries - adtEq (n1 :/ dt1) (n2 :/ dt2) = n1 == n2 && dtEq dt1 dt2 - - dtEq (Dir n1 d1) (Dir n2 d2) = n1 == n2 && and (zipWith dtEq d1 d2) - dtEq (File n1 t1) (File n2 t2) = n1 == n2 && t1 == t2 - dtEq _ _ = False - - ------------------------------------------------------------------------------- --- | This is the core of the functions in this module. It converts a --- list of filepaths into a list of 'AnchoredDirTree' annotated with --- the modification times of the files located in those paths. -readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime] -readModificationTimes = mapM $ readDirectoryWith getModificationTime diff --git a/src/Snap/Extension/Server.hs b/src/Snap/Extension/Server.hs deleted file mode 100644 --- a/src/Snap/Extension/Server.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -{-| - -This module provides replacements for the 'httpServe' and 'quickHttpServe' -functions exported by 'Snap.Http.Server'. By taking a 'Initializer' as an -argument, these functions simplify the glue code that is needed to use Snap -Extensions. - --} - -module Snap.Extension.Server - ( ConfigExtend - , httpServe - , quickHttpServe - , defaultConfig - , getReloadHandler - , setReloadHandler - , module Snap.Http.Server.Config - ) where - -import Control.Exception (SomeException) -import Control.Monad -import Control.Monad.CatchIO -import Data.ByteString (ByteString) -import Data.Maybe -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Prelude hiding (catch) -import Snap.Extension -import Snap.Http.Server (simpleHttpServe) -import qualified Snap.Http.Server.Config as C -import Snap.Http.Server.Config hiding ( defaultConfig - , completeConfig - , getOther - , setOther - ) -import Snap.Util.GZip -import Snap.Types -import System.IO - - ------------------------------------------------------------------------------- --- | 'ConfigExtend' is similar to the 'Config' exported by 'Snap.Http.Server', --- but is augmented with a @reloadHandler@ field which can be accessed using --- 'getReloadHandler' and 'setReloadHandler'. -type ConfigExtend s = Config - (SnapExtend s) (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ()) - - ------------------------------------------------------------------------------- -getReloadHandler :: ConfigExtend s -> Maybe - (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ()) -getReloadHandler = C.getOther - - ------------------------------------------------------------------------------- -setReloadHandler :: (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ()) - -> ConfigExtend s - -> ConfigExtend s -setReloadHandler = C.setOther - - - - ------------------------------------------------------------------------------- --- | These are the default values for all the fields in 'ConfigExtend'. --- --- > hostname = "localhost" --- > address = "0.0.0.0" --- > port = 8000 --- > accessLog = "log/access.log" --- > errorLog = "log/error.log" --- > locale = "en_US" --- > compression = True --- > verbose = True --- > errorHandler = prints the error message --- > reloadHandler = prints the result of each reload handler (error/success) --- -defaultConfig :: ConfigExtend s -defaultConfig = setReloadHandler handler C.defaultConfig - where - handler = path "admin/reload" . defaultReloadHandler - - ------------------------------------------------------------------------------- --- | Completes a partial 'Config' by filling in the unspecified values with --- the default values from 'defaultConfig'. -completeConfig :: ConfigExtend s -> ConfigExtend s -completeConfig c = case getListen c' of - [] -> addListen (ListenHttp "0.0.0.0" 8000) c' - _ -> c' - where c' = mappend defaultConfig c - - ------------------------------------------------------------------------------- --- | Starts serving HTTP requests using the given handler, with settings from --- the 'ConfigExtend' passed in. This function never returns; to shut down --- the HTTP server, kill the controlling thread. -httpServe :: ConfigExtend s - -- ^ Any configuration options which override the defaults - -> Initializer s - -- ^ The 'Initializer' function for the application's monad - -> SnapExtend s () - -- ^ The application to be served - -> IO () -httpServe config initializer handler = do - (snap, cleanup) <- runInitializerWithReloadAction - verbose - initializer - (catch500 handler) - reloader - let site = compress $ snap - mapM_ printListen $ C.getListen config - _ <- try $ serve $ site :: IO (Either SomeException ()) - putStr "\n" - cleanup - output "Shutting down..." - - where - conf = completeConfig config - verbose = fromJust $ getVerbose conf - output = when verbose . hPutStrLn stderr - reloader = fromJust $ getReloadHandler conf - compress = if fromJust $ getCompression conf then withCompression else id - catch500 = flip catch $ fromJust $ getErrorHandler conf - serve = simpleHttpServe config - - listenToString (C.ListenHttp host port) = - concat ["http://", fromUTF8 host, ":", show port, "/"] - listenToString (C.ListenHttps host port _ _) = - concat ["https://", fromUTF8 host, ":", show port, "/"] - - printListen l = output $ "Listening on " ++ listenToString l - - ------------------------------------------------------------------------------- --- | Starts serving HTTP using the given handler. The configuration is read --- from the options given on the command-line, as returned by --- 'commandLineConfig'. -quickHttpServe :: Initializer s - -- ^ The 'Initializer' function for the application's monad - -> SnapExtend s () - -- ^ The application to be served - -> IO () -quickHttpServe r m = commandLineConfig emptyConfig >>= \c -> httpServe c r m - ------------------------------------------------------------------------------- -fromUTF8 :: ByteString -> String -fromUTF8 = T.unpack . T.decodeUtf8 diff --git a/src/Snap/Snaplet.hs b/src/Snap/Snaplet.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeOperators #-} + +{-| + +Snaplets allow you to build web applications out of composable parts. This +allows you to build self-contained units and glue them together to make your +overall application. + +A snaplet has a few moving parts, some user-defined and some provided by the +snaplet API: + + * each snaplet has its own configuration given to it at startup. + + * each snaplet is given its own directory on the filesystem, from which it + reads its configuration and in which it can store files. + + * each snaplet comes with an 'Initializer' which defines how to create an + instance of the Snaplet at startup. The initializer decides how to + interpret the snaplet configuration, which URLs to handle (and how), sets + up the initial snaplet state, tells the snaplet runtime system how to + clean the snaplet up, etc. + + * each snaplet contains some user-defined in-memory state; for instance, a + snaplet that talks to a database might contain a reference to a connection + pool. The snaplet state is an ordinary Haskell record, with a datatype + defined by the snaplet author. The initial state record is created during + initialization and is available to snaplet 'Handler's when serving HTTP + requests. + +NOTE: This documentation is written as a prose tutorial of the snaplets +API. Don't be scared by the fact that it's auto-generated and is filled with +type signatures. Just keep reading. + +-} + +module Snap.Snaplet + ( + -- * Snaplet + -- $snapletDoc + Snaplet + , SnapletConfig + + -- * Lenses + -- $lenses + + -- * Snaplet Helper Functions + -- $snapletHelpers + , snapletConfig + , snapletValue + , subSnaplet + + -- * MonadSnaplet + -- $monadSnaplet + , MonadSnaplet(..) + , getSnapletAncestry + , getSnapletFilePath + , getSnapletName + , getSnapletDescription + , getSnapletUserConfig + , getSnapletRootURL + , snapletURL + , getRoutePattern + , setRoutePattern + + -- * Snaplet state manipulation + -- $snapletState + , getSnapletState + , putSnapletState + , modifySnapletState + , getsSnapletState + +-- , wrap +-- , wrapTop + + -- * Initializer + -- $initializer + , Initializer + , SnapletInit + , makeSnaplet + + , nestSnaplet + , embedSnaplet + , nameSnaplet + + , onUnload + , addPostInitHook + , addPostInitHookBase + , printInfo + , getRoutes + , getEnvironment + + -- * Routes + -- $routes + , addRoutes + , wrapSite + + -- * Handlers + , Handler + , failIfNotLocal + , reloadSite + , modifyMaster + , bracketHandler + + -- * Serving Applications + , runSnaplet + , combineConfig + , serveSnaplet + , serveSnapletNoArgParsing + , loadAppConfig + + -- * Snaplet Lenses + , SnapletLens + ) where + + +import Snap.Snaplet.Internal.Initializer +import Snap.Snaplet.Internal.Types + +-- $snapletDoc +-- The heart of the snaplets infrastructure is state management. (Note: when +-- we say \"state\" here, we mean in-memory Haskell objects, not external data +-- storage or databases; how you deal with persisted data is up to you.) Most +-- nontrivial pieces of a web application need some kind of runtime state or +-- environment data. The datatype we use to handle this is called 'Snaplet': + +-- $snapletHelpers +-- +-- Your web application will itself get wrapped in a 'Snaplet', and the +-- top-level user state of your application (which will likely contain other +-- snaplets nested inside it) will look something like this: +-- +-- > data App = App +-- > { _foo :: Snaplet Foo +-- > , _bar :: Snaplet Bar +-- > , _someNonSnapletData :: String +-- > } +-- +-- Every web application using snaplets has a top-most user state which +-- contains all of the application state; we call this state the \"base\" +-- state. +-- +-- We export several helper lenses for working with Snaplet types. + +-- $lenses +-- In the example above, the @Foo@ snaplet has to be written to work with any +-- base state (otherwise it wouldn't be reusable!), but functions written to +-- work with the @Foo@ snaplet want to be able to modify the @Foo@ record +-- /within the context/ of the base state. Given that Haskell datatypes are +-- pure, how do you allow for this? +-- +-- Our solution is to use /lenses/, as defined in Edward Kmett's @lens@ +-- library (). A lens, notated +-- as follows: +-- +-- > SimpleLens a b +-- +-- is conceptually a \"getter\" and a \"setter\" rolled up into one. The +-- @lens@ library provides the following functions: +-- +-- > view :: (SimpleLens a b) -> a -> b +-- > set :: (SimpleLens a b) -> b -> a -> a +-- > over :: (SimpleLens a b) -> (b -> b) -> a -> a +-- +-- which allow you to get, set, and modify a value of type @b@ within the +-- context of type @a@. The @lens@ package comes with a Template Haskell +-- function called 'makeLenses', which auto-magically defines a lens for every +-- record field having a name beginning with an underscore. In the @App@ +-- example above, adding the declaration: +-- +-- > makeLenses ''App +-- +-- would define lenses: +-- +-- > foo :: SimpleLens App (Snaplet Foo) +-- > bar :: SimpleLens App (Snaplet Bar) +-- > someNonSnapletData :: SimpleLens App String +-- +-- The coolest thing about @lens@ lenses is that they /compose/ using the +-- @(.)@ operator. If the @Foo@ type had a field of type @Quux@ within it with +-- a lens @quux :: SimpleLens Foo Quux@, then you could create a lens of type +-- @SimpleLens App Quux@ by composition: +-- +-- > import Control.Lens +-- > +-- > data Foo = Foo { _quux :: Quux } +-- > makeLenses ''Foo +-- > +-- > -- snapletValue is defined in the framework: +-- > snapletValue :: SimpleLens (Snaplet a) a +-- > +-- > appQuuxLens :: SimpleLens App Quux +-- > appQuuxLens = foo . snapletValue . quux +-- +-- Lens composition is very similar to function composition except it works in +-- the opposite direction (think Java-style System.out.println ordering) and +-- it gives you a composed getter and setter at the same time. + +-- $monadSnaplet +-- The primary abstraction in the snaplet infrastructure is a combination of +-- the reader and state monads. The state monad holds the top level +-- application data type (from now on referred to as the base state). The +-- reader monad holds a lens from the base state to the current snaplet's +-- state. This allows quux snaplet functions to access and modify the Quux +-- data structure without knowing anything about the App or Foo data +-- structures. It also lets other snaplets call functions from the quux +-- snaplet if they have the quux snaplet's lens @SimpleLens App (Snaplet Quux)@. +-- We can view our application as a tree of snaplets and other pieces of data. +-- The lenses are like pointers to nodes of the tree. If you have a pointer to +-- a node, you can access the node and all of its children without knowing +-- anything about the rest of the tree. +-- +-- Several monads use this infrastructure. These monads need at least three +-- type parameters. Two for the lens type, and the standard \'a\' denoting the +-- monad return value. You will usually see this written in type signatures as +-- \"m b v a\" or some variation. The \'m\' is the type variable of the +-- MonadSnaplet type class. \'b\' is the base state, and \'v\' is the state of +-- the current \"view\" snaplet (or simply, current state). +-- +-- The MonadSnaplet type class distills the essence of the operations used +-- with this pattern. Its functions define fundamental methods for navigating +-- snaplet trees. + +-- $snapletState +-- MonadSnaplet instances will typically have @MonadState v@ instances. We +-- provide the following convenience functions which give the equivalent to +-- @MonadState (Snaplet v)@ for the less common cases where you need to work +-- with the Snaplet wrapper. + +-- $initializer +-- The Initializer monad is where your application's initialization happens. +-- Initializers are run at startup and any time a site reload is triggered. +-- The Initializer's job is to construct a snaplet's routes and initial state, +-- set up filesystem data, read config files, etc. +-- +-- In order to initialize its state, a snaplet needs to initialize all the +-- @Snaplet a@ state for each of its subsnaplets. The only way to construct +-- a @Snaplet a@ type is by calling 'nestSnaplet' or 'embedSnaplet' from +-- within an initializer. + + +-- $writingSnaplets +-- When writing a snaplet, you must define an initializer function. The +-- initializer function for the Foo snaplet (where Foo is the snaplet's +-- state type) must have a return type of @Initializer b Foo Foo@. +-- To create an initializer like this, you have to use the 'makeSnaplet' +-- function. It takes care of the necessary internal bookkeeping needed when +-- initializing a new snaplet. Haskell's strong type system allows us to +-- ensure that calling 'makeSnaplet' is the only way you can construct a +-- Snaplet type. + + +-- $routes +-- Snaplet initializers are also responsible for setting up any routes defined +-- by the snaplet. To do that you'll usually use either 'addRoutes' or +-- 'wrapSite'. + + +{- + + +/FIXME/: finish this section + + +Discuss: + + * lenses and how snaplet apps are built out of parts. + + * the initializer type, and what you can do with it + + * layout of snaplets on disk, and how on-disk stuff can be auto-populated + from the cabal data directory + + * the handler type, and what you can do with it + + + + +{FIXME: strike/rewrite these sentences. Components that do not need any kind +of state or environment are probably more appropriate as a standalone +library than as a snaplet. + +We start our application by defining a data structure to hold the state. +This data structure includes the state of any snaplets (wrapped in a +Snaplet) we want to use as well as any other state we might want.} + +> module MyApp where +> import Control.Lens +> import Snap.Snaplet +> import Snap.Snaplet.Heist +> +> data App = App +> { _heist :: Snaplet (Heist App) +> , _foo :: Snaplet Foo +> , _bar :: Snaplet Bar +> , _companyName :: String +> } +> +> makeLenses ''App + +The next thing we need to do is define an initializer. + +> app :: Initializer App App App +> app = do +> hs <- nestSnaplet "heist" $ heistInit "templates" +> fs <- nestSnaplet "foo" $ fooInit heist +> bs <- nestSnaplet "" $ nameSnaplet "baz" $ barInit heist +> addRoutes [ ("/hello", writeText "hello world") +> ] +> wrapSite (<|> with heist heistServe) +> return $ App hs fs bs "fooCorp" + +Then we define a simple main to run the application. + +> main = serveSnaplet defaultConfig app + + + +Snaplet filesystem directory structure: + +> snaplet +> |-- snaplet.cabal +> |-- log/ +> |-- src/ +> ------------------------ +> |-- db.cfg +> |-- snaplet.cfg +> |-- public/ +> |-- stylesheets/ +> |-- images/ +> |-- js/ +> |-- snaplets +> |-- subsnaplet1/ +> |-- subsnaplet2/ +> |-- templates/ + +-} + diff --git a/src/Snap/Snaplet/Auth.hs b/src/Snap/Snaplet/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +------------------------------------------------------------------------------ +-- | +-- +-- This module contains all the central authentication functionality. +-- +-- It exports a number of high-level functions to be used directly in your +-- application handlers. +-- +-- We also export a number of mid-level functions that should be helpful when +-- you are integrating with another way of confirming the authentication of +-- login requests. +-- + +module Snap.Snaplet.Auth + ( + -- * Higher Level Handler Functions + createUser + , usernameExists + , saveUser + , destroyUser + , loginByUsername + , loginByRememberToken + , forceLogin + , logout + , currentUser + , isLoggedIn + + -- * Lower Level Functions + , markAuthSuccess + , markAuthFail + , checkPasswordAndLogin + + -- * Types + , AuthManager(..) + , IAuthBackend(..) + , AuthSettings(..) + , defAuthSettings + , AuthUser(..) + , defAuthUser + , UserId(..) + , Password(..) + , AuthFailure(..) + , Role(..) + + -- * Other Utilities + , authSettingsFromConfig + , withBackend + , encryptPassword + , checkPassword + , authenticatePassword + , setPassword + , encrypt + , verify + + -- * Handlers + , registerUser + , loginUser + , logoutUser + , requireUser + , setPasswordResetToken + , clearPasswordResetToken + + -- * Splice helpers + , addAuthSplices + , compiledAuthSplices + , userCSplices + , userISplices + , ifLoggedIn + , ifLoggedOut + , loggedInUser + ) + where + +------------------------------------------------------------------------------ +import Snap.Snaplet.Auth.AuthManager +import Snap.Snaplet.Auth.Handlers +import Snap.Snaplet.Auth.SpliceHelpers +import Snap.Snaplet.Auth.Types + diff --git a/src/Snap/Snaplet/Auth/AuthManager.hs b/src/Snap/Snaplet/Auth/AuthManager.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/AuthManager.hs @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- | Internal module exporting AuthManager implementation. +-- +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Snap.Snaplet.Auth.AuthManager + ( -- * AuthManager Datatype + AuthManager(..) + + -- * Backend Typeclass + , IAuthBackend(..) + + -- * Context-free Operations + , buildAuthUser + ) where + +------------------------------------------------------------------------------ +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Time +import Web.ClientSession + +import Snap.Snaplet +import Snap.Snaplet.Session +import Snap.Snaplet.Auth.Types + + +------------------------------------------------------------------------------ +-- | Creates a new user from a username and password. +-- +buildAuthUser :: IAuthBackend r => + r -- ^ An auth backend + -> Text -- ^ Username + -> ByteString -- ^ Password + -> IO (Either AuthFailure AuthUser) +buildAuthUser r unm pass = do + now <- getCurrentTime + let au = defAuthUser { + userLogin = unm + , userPassword = Nothing + , userCreatedAt = Just now + , userUpdatedAt = Just now + } + au' <- setPassword au pass + save r au' + + +------------------------------------------------------------------------------ +-- | All storage backends need to implement this typeclass +-- +class IAuthBackend r where + -- | Create or update the given 'AuthUser' record. A 'userId' of Nothing + -- indicates that a new user should be created, otherwise the user + -- information for that userId should be updated. + save :: r -> AuthUser -> IO (Either AuthFailure AuthUser) + lookupByUserId :: r -> UserId -> IO (Maybe AuthUser) + lookupByLogin :: r -> Text -> IO (Maybe AuthUser) + lookupByEmail :: r -> Text -> IO (Maybe AuthUser) + lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser) + destroy :: r -> AuthUser -> IO () + + +------------------------------------------------------------------------------ +-- | Abstract data type holding all necessary information for auth operation +data AuthManager b = forall r. IAuthBackend r => AuthManager { + backend :: r + -- ^ Storage back-end + + , session :: SnapletLens b SessionManager + -- ^ A lens pointer to a SessionManager + + , activeUser :: Maybe AuthUser + -- ^ A per-request logged-in user cache + + , minPasswdLen :: Int + -- ^ Password length range + + , rememberCookieName :: ByteString + -- ^ Cookie name for the remember token + + , rememberCookieDomain :: Maybe ByteString + -- ^ Domain for which remember cookie will be created. + + , rememberPeriod :: Maybe Int + -- ^ Remember period in seconds. Defaults to 2 weeks. + + , siteKey :: Key + -- ^ A unique encryption key used to encrypt remember cookie + + , lockout :: Maybe (Int, NominalDiffTime) + -- ^ Lockout after x tries, re-allow entry after y seconds + + , randomNumberGenerator :: RNG + -- ^ Random number generator + } + +instance IAuthBackend (AuthManager b) where + save AuthManager{..} u = save backend u + lookupByUserId AuthManager{..} u = lookupByUserId backend u + lookupByLogin AuthManager{..} u = lookupByLogin backend u + lookupByEmail AuthManager{..} u = lookupByEmail backend u + lookupByRememberToken AuthManager{..} u = lookupByRememberToken backend u + destroy AuthManager{..} u = destroy backend u diff --git a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Snap.Snaplet.Auth.Backends.JsonFile + ( initJsonFileAuthManager + , mkJsonAuthMgr + ) where + + +import Control.Applicative ((<|>)) +import Control.Monad (join) +import Control.Monad.State +import Control.Concurrent.STM +import Data.Aeson +import Data.Aeson.Parser (json) +import qualified Data.Attoparsec.ByteString as Atto +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString as B +import qualified Data.Map as HM +import Data.Map (Map) +import Data.Maybe (fromJust, isJust, listToMaybe) +import Data.Monoid (mempty) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import Web.ClientSession +import System.Directory + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Snap.Snaplet +import Snap.Snaplet.Auth.Types +import Snap.Snaplet.Auth.AuthManager +import Snap.Snaplet.Session + + + +------------------------------------------------------------------------------ +-- | Initialize a JSON file backed 'AuthManager' +initJsonFileAuthManager :: AuthSettings + -- ^ Authentication settings for your app + -> SnapletLens b SessionManager + -- ^ Lens into a 'SessionManager' auth snaplet will + -- use + -> FilePath + -- ^ Where to store user data as JSON + -> SnapletInit b (AuthManager b) +initJsonFileAuthManager s l db = do + makeSnaplet + "JsonFileAuthManager" + "A snaplet providing user authentication using a JSON-file backend" + Nothing $ liftIO $ do + rng <- liftIO mkRNG + key <- getKey (asSiteKey s) + jsonMgr <- mkJsonAuthMgr db + return $! AuthManager { + backend = jsonMgr + , session = l + , activeUser = Nothing + , minPasswdLen = asMinPasswdLen s + , rememberCookieName = asRememberCookieName s + , rememberCookieDomain = Nothing + , rememberPeriod = asRememberPeriod s + , siteKey = key + , lockout = asLockout s + , randomNumberGenerator = rng + } + + +------------------------------------------------------------------------------ +-- | Load/create a datafile into memory cache and return the manager. +-- +-- This data type can be used by itself for batch/non-handler processing. +mkJsonAuthMgr :: FilePath -> IO JsonFileAuthManager +mkJsonAuthMgr fp = do + db <- loadUserCache fp + let db' = case db of + Left e -> error e + Right x -> x + cache <- newTVarIO db' + + return $! JsonFileAuthManager { + memcache = cache + , dbfile = fp + } + + +------------------------------------------------------------------------------ +type UserIdCache = Map UserId AuthUser + +#if !MIN_VERSION_aeson(1,0,0) +-- In aeson >= 1 these instances are not needed because we have +-- derived ToJSONKey/FromJSONKey instances for UserId. +instance ToJSON UserIdCache where + toJSON m = toJSON $ HM.toList m + +instance FromJSON UserIdCache where + parseJSON = fmap HM.fromList . parseJSON +#endif + +------------------------------------------------------------------------------ +type LoginUserCache = Map Text UserId + + +------------------------------------------------------------------------------ +type EmailUserCache = Map Text UserId + + +------------------------------------------------------------------------------ +type RemTokenUserCache = Map Text UserId + + +------------------------------------------------------------------------------ +-- | JSON user back-end stores the user data and indexes for login and token +-- based logins. +data UserCache = UserCache { + uidCache :: UserIdCache -- ^ the actual datastore + , loginCache :: LoginUserCache -- ^ fast lookup for login field + , emailCache :: EmailUserCache -- ^ fast lookup for email field + , tokenCache :: RemTokenUserCache -- ^ fast lookup for remember tokens + , uidCounter :: Int -- ^ user id counter +} + + +------------------------------------------------------------------------------ +defUserCache :: UserCache +defUserCache = UserCache { + uidCache = HM.empty + , loginCache = HM.empty + , emailCache = HM.empty + , tokenCache = HM.empty + , uidCounter = 0 +} + + +------------------------------------------------------------------------------ +loadUserCache :: FilePath -> IO (Either String UserCache) +loadUserCache fp = do + chk <- doesFileExist fp + case chk of + True -> do + d <- B.readFile fp + case Atto.parseOnly json d of + Left e -> return $! Left $ + "Can't open JSON auth backend. Error: " ++ e + Right v -> case fromJSON v of + Error e -> return $! Left $ + "Malformed JSON auth data store. Error: " ++ e + Success db -> return $! Right db + False -> do + putStrLn "User JSON datafile not found. Creating a new one." + return $ Right defUserCache + + +------------------------------------------------------------------------------ +data JsonFileAuthManager = JsonFileAuthManager { + memcache :: TVar UserCache + , dbfile :: FilePath +} + + +------------------------------------------------------------------------------ +jsonFileSave :: JsonFileAuthManager + -> AuthUser + -> IO (Either AuthFailure AuthUser) +jsonFileSave mgr u = do + now <- getCurrentTime + oldByLogin <- lookupByLogin mgr (userLogin u) + oldById <- case userId u of + Nothing -> return Nothing + Just x -> lookupByUserId mgr x + + res <- atomically $ do + cache <- readTVar (memcache mgr) + res <- case userId u of + Nothing -> create cache now oldByLogin + Just _ -> update cache now oldById + case res of + Left e -> return $! Left e + Right (cache', u') -> do + writeTVar (memcache mgr) cache' + return $! Right $! (cache', u') + + case res of + Left _ -> return $! Left BackendError + Right (cache', u') -> do + dumpToDisk cache' + return $! Right u' + + where + -------------------------------------------------------------------------- + create :: UserCache + -> UTCTime + -> (Maybe AuthUser) + -> STM (Either AuthFailure (UserCache, AuthUser)) + create cache now old = do + case old of + Just _ -> return $! Left DuplicateLogin + Nothing -> do + new <- do + let uid' = UserId . showT $ uidCounter cache + 1 + let u' = u { userUpdatedAt = Just now, userId = Just uid' } + return $! cache { + uidCache = HM.insert uid' u' $ uidCache cache + , loginCache = HM.insert (userLogin u') uid' $ loginCache cache + , emailCache = maybe id (\em -> HM.insert em uid') (userEmail u) $ + emailCache cache + , tokenCache = case userRememberToken u' of + Nothing -> tokenCache cache + Just x -> HM.insert x uid' $ tokenCache cache + , uidCounter = uidCounter cache + 1 + } + return $! Right (new, getLastUser new) + + -------------------------------------------------------------------------- + -- lookup old record, see what's changed and update indexes accordingly + update :: UserCache + -> UTCTime + -> (Maybe AuthUser) + -> STM (Either AuthFailure (UserCache, AuthUser)) + update cache now old = + case old of + Nothing -> return $! Left UserNotFound + Just x -> do + let oldLogin = userLogin x + let oldEmail = userEmail x + let oldToken = userRememberToken x + let uid = fromJust $ userId u + let newLogin = userLogin u + let newEmail = userEmail u + let newToken = userRememberToken u + + let lc = if oldLogin /= userLogin u + then HM.insert newLogin uid $ + HM.delete oldLogin $ + loginCache cache + else loginCache cache + + let ec = if oldEmail /= newEmail + then (case (oldEmail, newEmail) of + (Nothing, Nothing) -> id + (Just e, Nothing) -> HM.delete e + (Nothing, Just e ) -> HM.insert e uid + (Just e, Just e') -> HM.insert e' uid . + HM.delete e + ) (emailCache cache) + else emailCache cache + + let tc = if oldToken /= newToken && isJust oldToken + then HM.delete (fromJust oldToken) $ loginCache cache + else tokenCache cache + + let tc' = case newToken of + Just t -> HM.insert t uid tc + Nothing -> tc + + let u' = u { userUpdatedAt = Just now } + + let new = cache { + uidCache = HM.insert uid u' $ uidCache cache + , loginCache = lc + , emailCache = ec + , tokenCache = tc' + } + + return $! Right (new, u') + + -------------------------------------------------------------------------- + -- Sync user database to disk + -- Need to implement a mutex here; simult syncs could screw things up + dumpToDisk c = LB.writeFile (dbfile mgr) (encode c) + + -------------------------------------------------------------------------- + -- Gets the last added user + getLastUser cache = maybe e id $ getUser cache uid + where + uid = UserId . showT $ uidCounter cache + e = error "getLastUser failed. This should not happen." + + +------------------------------------------------------------------------------ +instance IAuthBackend JsonFileAuthManager where + save = jsonFileSave + + destroy = error "JsonFile: destroy is not yet implemented" + + lookupByUserId mgr uid = withCache mgr f + where + f cache = getUser cache uid + + lookupByLogin mgr login = withCache mgr f + where + f cache = getUid >>= getUser cache + where getUid = HM.lookup login (loginCache cache) + + lookupByEmail mgr email = withCache mgr f + where + f cache = getEmail >>= getUser cache + where getEmail = case HM.lookup email (emailCache cache) of + Just u -> return u + Nothing -> (join . fmap userId . + listToMaybe . HM.elems $ + HM.filter ((== Just email) . userEmail) + (uidCache cache)) + + lookupByRememberToken mgr token = withCache mgr f + where + f cache = getUid >>= getUser cache + where + getUid = HM.lookup token (tokenCache cache) + + +------------------------------------------------------------------------------ +withCache :: JsonFileAuthManager -> (UserCache -> a) -> IO a +withCache mgr f = atomically $ do + cache <- readTVar $ memcache mgr + return $! f cache + + +------------------------------------------------------------------------------ +getUser :: UserCache -> UserId -> Maybe AuthUser +getUser cache uid = HM.lookup uid (uidCache cache) + + +------------------------------------------------------------------------------ +showT :: Int -> Text +showT = T.pack . show + + + -------------------- + -- JSON Instances -- + -------------------- + +------------------------------------------------------------------------------ +instance ToJSON UserCache where + toJSON uc = object + [ "uidCache" .= uidCache uc + , "loginCache" .= loginCache uc + , "emailCache" .= emailCache uc + , "tokenCache" .= tokenCache uc + , "uidCounter" .= uidCounter uc + ] + + +------------------------------------------------------------------------------ +instance FromJSON UserCache where + parseJSON (Object v) = + UserCache + <$> v .: "uidCache" + <*> v .: "loginCache" + <*> (v .: "emailCache" <|> pure mempty) -- Old versions of users.json do + -- not carry this field + <*> v .: "tokenCache" + <*> v .: "uidCounter" + parseJSON _ = error "Unexpected JSON input" diff --git a/src/Snap/Snaplet/Auth/Handlers.hs b/src/Snap/Snaplet/Auth/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Handlers.hs @@ -0,0 +1,546 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + +------------------------------------------------------------------------------ +-- | Pre-packaged Handlers that deal with form submissions and standard +-- use-cases involving authentication. + +module Snap.Snaplet.Auth.Handlers where + +------------------------------------------------------------------------------ +import Control.Applicative +import Control.Monad (join, liftM, liftM2) +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Data.ByteString (ByteString) +import Data.Maybe +import Data.Serialize hiding (get) +import Data.Time +import Data.Text.Encoding (decodeUtf8) +import Data.Text (Text, null, strip) +import Prelude hiding (null) +import Web.ClientSession +------------------------------------------------------------------------------ +import Snap.Core +import Snap.Snaplet +import Snap.Snaplet.Auth.AuthManager +import Snap.Snaplet.Auth.Types +import Snap.Snaplet.Session +------------------------------------------------------------------------------ + + + ---------------------------- + -- Higher level functions -- + ---------------------------- + +------------------------------------------------------------------------------ +-- | Create a new user from just a username and password +-- +createUser :: Text -- ^ Username + -> ByteString -- ^ Password + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +createUser unm pwd + | null $ strip unm = return $ Left UsernameMissing + | otherwise = do + uExists <- usernameExists unm + if uExists then return $ Left DuplicateLogin + else withBackend $ \r -> liftIO $ buildAuthUser r unm pwd + + +------------------------------------------------------------------------------ +-- | Check whether a user with the given username exists. +-- +usernameExists :: Text -- ^ The username to be checked + -> Handler b (AuthManager b) Bool +usernameExists username = + withBackend $ \r -> liftIO $ isJust <$> lookupByLogin r username + + +------------------------------------------------------------------------------ +-- | Lookup a user by her username, check given password and perform login +-- +loginByUsername :: Text -- ^ Username/login for user + -> Password -- ^ Should be ClearText + -> Bool -- ^ Set remember token? + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +loginByUsername _ (Encrypted _) _ = return $ Left EncryptedPassword +loginByUsername unm pwd shouldRemember = do + sk <- gets siteKey + cn <- gets rememberCookieName + cd <- gets rememberCookieDomain + rp <- gets rememberPeriod + withBackend $ loginByUsername' sk cn cd rp + + where + -------------------------------------------------------------------------- + loginByUsername' :: (IAuthBackend t) => + Key + -> ByteString + -> Maybe ByteString + -> Maybe Int + -> t + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) + loginByUsername' sk cn cd rp r = + liftIO (lookupByLogin r unm) >>= + maybe (return $! Left UserNotFound) found + + where + ---------------------------------------------------------------------- + found user = checkPasswordAndLogin user pwd >>= + either (return . Left) matched + + ---------------------------------------------------------------------- + matched user + | shouldRemember = do + token <- gets randomNumberGenerator >>= + liftIO . randomToken 64 + + setRememberToken sk cn cd rp token + + let user' = user { + userRememberToken = Just (decodeUtf8 token) + } + + saveUser user' + return $! Right user' + + | otherwise = return $ Right user + + +------------------------------------------------------------------------------ +-- | Remember user from the remember token if possible and perform login +-- +loginByRememberToken :: Handler b (AuthManager b) (Either AuthFailure AuthUser) +loginByRememberToken = withBackend $ \impl -> do + key <- gets siteKey + cookieName_ <- gets rememberCookieName + period <- gets rememberPeriod + + res <- runMaybeT $ do + token <- MaybeT $ getRememberToken key cookieName_ period + MaybeT $ liftIO $ lookupByRememberToken impl $ decodeUtf8 token + case res of + Nothing -> return $ Left $ AuthError + "loginByRememberToken: no remember token" + Just user -> do + forceLogin user + return $ Right user + + +------------------------------------------------------------------------------ +-- | Logout the active user +-- +logout :: Handler b (AuthManager b) () +logout = do + s <- gets session + withTop s $ withSession s removeSessionUserId + rc <- gets rememberCookieName + rd <- gets rememberCookieDomain + expireSecureCookie rc rd + modify $ \mgr -> mgr { activeUser = Nothing } + + +------------------------------------------------------------------------------ +-- | Return the current user; trying to remember from cookie if possible. +-- +currentUser :: Handler b (AuthManager b) (Maybe AuthUser) +currentUser = cacheOrLookup $ withBackend $ \r -> do + s <- gets session + uid <- withTop s getSessionUserId + case uid of + Nothing -> either (const Nothing) Just <$> loginByRememberToken + Just uid' -> liftIO $ lookupByUserId r uid' + + +------------------------------------------------------------------------------ +-- | Convenience wrapper around 'rememberUser' that returns a bool result +-- +isLoggedIn :: Handler b (AuthManager b) Bool +isLoggedIn = isJust <$> currentUser + + +------------------------------------------------------------------------------ +-- | Create or update a given user +-- +saveUser :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +saveUser u + | null $ userLogin u = return $ Left UsernameMissing + | otherwise = withBackend $ \r -> liftIO $ save r u + + +------------------------------------------------------------------------------ +-- | Destroy the given user +-- +destroyUser :: AuthUser -> Handler b (AuthManager b) () +destroyUser u = withBackend $ liftIO . flip destroy u + + + ----------------------------------- + -- Lower level helper functions -- + ----------------------------------- + +------------------------------------------------------------------------------ +-- | Mutate an 'AuthUser', marking failed authentication +-- +-- This will save the user to the backend. +-- +markAuthFail :: AuthUser + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +markAuthFail u = withBackend $ \r -> do + lo <- gets lockout + incFailCtr u >>= checkLockout lo >>= liftIO . save r + + where + -------------------------------------------------------------------------- + incFailCtr u' = return $ u' { + userFailedLoginCount = userFailedLoginCount u' + 1 + } + + -------------------------------------------------------------------------- + checkLockout lo u' = + case lo of + Nothing -> return u' + Just (mx, wait) -> + if userFailedLoginCount u' >= mx + then do + now <- liftIO getCurrentTime + let reopen = addUTCTime wait now + return $! u' { userLockedOutUntil = Just reopen } + else return u' + + +------------------------------------------------------------------------------ +-- | Mutate an 'AuthUser', marking successful authentication +-- +-- This will save the user to the backend. +-- +markAuthSuccess :: AuthUser + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +markAuthSuccess u = withBackend $ \r -> + incLoginCtr u >>= + updateIp >>= + updateLoginTS >>= + resetFailCtr >>= + liftIO . save r + where + -------------------------------------------------------------------------- + incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 } + + -------------------------------------------------------------------------- + updateIp u' = do + ip <- rqClientAddr <$> getRequest + return $ u' { userLastLoginIp = userCurrentLoginIp u' + , userCurrentLoginIp = Just ip } + + -------------------------------------------------------------------------- + updateLoginTS u' = do + now <- liftIO getCurrentTime + return $ + u' { userCurrentLoginAt = Just now + , userLastLoginAt = userCurrentLoginAt u' } + + -------------------------------------------------------------------------- + resetFailCtr u' = return $ u' { userFailedLoginCount = 0 + , userLockedOutUntil = Nothing } + + +------------------------------------------------------------------------------ +-- | Authenticate and log the user into the current session if successful. +-- +-- This is a mid-level function exposed to allow roll-your-own ways of looking +-- up a user from the database. +-- +-- This function will: +-- +-- 1. Check the password +-- +-- 2. Login the user into the current session +-- +-- 3. Mark success/failure of the authentication trial on the user record +-- +checkPasswordAndLogin + :: AuthUser -- ^ An existing user, somehow looked up from db + -> Password -- ^ A ClearText password + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +checkPasswordAndLogin u pw = + case userLockedOutUntil u of + Just x -> do + now <- liftIO getCurrentTime + if now > x + then auth u + else return . Left $ LockedOut x + Nothing -> auth u + + where + auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser) + auth user = + case authenticatePassword user pw of + Just e -> do + markAuthFail user + return $ Left e + + Nothing -> do + forceLogin user + modify (\mgr -> mgr { activeUser = Just user }) + markAuthSuccess user + + +------------------------------------------------------------------------------ +-- | Login and persist the given 'AuthUser' in the active session +-- +-- Meant to be used if you have other means of being sure that the person is +-- who she says she is. +-- +forceLogin :: AuthUser -- ^ An existing user, somehow looked up from db + -> Handler b (AuthManager b) (Either AuthFailure ()) +forceLogin u = do + s <- gets session + withSession s $ + case userId u of + Just x -> do + withTop s (setSessionUserId x) + return $ Right () + Nothing -> return . Left $ + AuthError $ "forceLogin: Can't force the login of a user " + ++ "without userId" + + + ------------------------------------ + -- Internal, non-exported helpers -- + ------------------------------------ + + +------------------------------------------------------------------------------ +getRememberToken :: (Serialize t, MonadSnap m) + => Key + -> ByteString + -> Maybe Int + -> m (Maybe t) +getRememberToken sk rc rp = getSecureCookie rc sk rp + + +------------------------------------------------------------------------------ +setRememberToken :: (Serialize t, MonadSnap m) + => Key + -> ByteString + -> Maybe ByteString + -> Maybe Int + -> t + -> m () +setRememberToken sk rc rd rp token = setSecureCookie rc rd sk rp token + + +------------------------------------------------------------------------------ +-- | Set the current user's 'UserId' in the active session +-- +setSessionUserId :: UserId -> Handler b SessionManager () +setSessionUserId (UserId t) = setInSession "__user_id" t + + +------------------------------------------------------------------------------ +-- | Remove 'UserId' from active session, effectively logging the user out. +removeSessionUserId :: Handler b SessionManager () +removeSessionUserId = deleteFromSession "__user_id" + + +------------------------------------------------------------------------------ +-- | Get the current user's 'UserId' from the active session +-- +getSessionUserId :: Handler b SessionManager (Maybe UserId) +getSessionUserId = do + uid <- getFromSession "__user_id" + return $ liftM UserId uid + + +------------------------------------------------------------------------------ +-- | Check password for a given user. +-- +-- Returns "Nothing" if check is successful and an "IncorrectPassword" error +-- otherwise +-- +authenticatePassword :: AuthUser -- ^ Looked up from the back-end + -> Password -- ^ Check against this password + -> Maybe AuthFailure +authenticatePassword u pw = auth + where + auth = case userPassword u of + Nothing -> Just PasswordMissing + Just upw -> check $ checkPassword pw upw + + check b = if b then Nothing else Just IncorrectPassword + + +------------------------------------------------------------------------------ +-- | Wrap lookups around request-local cache +-- +cacheOrLookup + :: Handler b (AuthManager b) (Maybe AuthUser) + -- ^ Lookup action to perform if request local cache is empty + -> Handler b (AuthManager b) (Maybe AuthUser) +cacheOrLookup f = do + au <- gets activeUser + if isJust au + then return au + else do + au' <- f + modify (\mgr -> mgr { activeUser = au' }) + return au' + + +------------------------------------------------------------------------------ +-- | Register a new user by specifying login and password 'Param' fields +-- +registerUser + :: ByteString -- ^ Login field + -> ByteString -- ^ Password field + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +registerUser lf pf = do + l <- fmap decodeUtf8 <$> getParam lf + p <- getParam pf + + let l' = maybe (Left UsernameMissing) Right l + let p' = maybe (Left PasswordMissing) Right p + + -- In case of multiple AuthFailure, the first available one + -- will be propagated. + case liftM2 (,) l' p' of + Left e -> return $ Left e + Right (lgn, pwd) -> createUser lgn pwd + + +------------------------------------------------------------------------------ +-- | A 'MonadSnap' handler that processes a login form. +-- +-- The request paremeters are passed to 'performLogin' +-- +-- To make your users stay logged in for longer than the session replay +-- prevention timeout, you must pass a field name as the third parameter and +-- that field must be set to a value of \"1\" by the submitting form. This +-- lets you use a user selectable check box. Or if you want user remembering +-- always turned on, you can use a hidden form field. +loginUser + :: ByteString + -- ^ Username field + -> ByteString + -- ^ Password field + -> Maybe ByteString + -- ^ Remember field; Nothing if you want no remember function. + -> (AuthFailure -> Handler b (AuthManager b) ()) + -- ^ Upon failure + -> Handler b (AuthManager b) () + -- ^ Upon success + -> Handler b (AuthManager b) () +loginUser unf pwdf remf loginFail loginSucc = + loginUser' unf pwdf remf >>= either loginFail (const loginSucc) + + +------------------------------------------------------------------------------ +loginUser' :: ByteString + -> ByteString + -> Maybe ByteString + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +loginUser' unf pwdf remf = do + mbUsername <- getParam unf + mbPassword <- getParam pwdf + remember <- liftM (fromMaybe False) + (runMaybeT $ + do field <- MaybeT $ return remf + value <- MaybeT $ getParam field + return $ value == "1" || value == "on") + + case mbUsername of + Nothing -> return $ Left UsernameMissing + Just u -> case mbPassword of + Nothing -> return $ Left PasswordMissing + Just p -> loginByUsername (decodeUtf8 u) (ClearText p) remember + + +------------------------------------------------------------------------------ +-- | Simple handler to log the user out. Deletes user from session. +-- +logoutUser :: Handler b (AuthManager b) () -- ^ What to do after logging out + -> Handler b (AuthManager b) () +logoutUser target = logout >> target + + +------------------------------------------------------------------------------ +-- | Require that an authenticated 'AuthUser' is present in the current +-- session. +-- +-- This function has no DB cost - only checks to see if a user_id is present +-- in the current session. +-- +requireUser :: SnapletLens b (AuthManager b) + -- ^ Lens reference to an "AuthManager" + -> Handler b v a + -- ^ Do this if no authenticated user is present. + -> Handler b v a + -- ^ Do this if an authenticated user is present. + -> Handler b v a +requireUser auth bad good = do + loggedIn <- withTop auth isLoggedIn + if loggedIn then good else bad + + +------------------------------------------------------------------------------ +-- | Run a function on the backend, and return the result. +-- +-- This uses an existential type so that the backend type doesn't +-- 'escape' AuthManager. The reason that the type is Handler b +-- (AuthManager v) a and not a is because anything that uses the +-- backend will return an IO something, which you can liftIO, or a +-- Handler b (AuthManager v) a if it uses other handler things. +-- +withBackend :: + (forall r. (IAuthBackend r) => r -> Handler b (AuthManager v) a) + -- ^ The function to run with the handler. + -> Handler b (AuthManager v) a +withBackend f = join $ do + (AuthManager backend_ _ _ _ _ _ _ _ _ _) <- get + return $ f backend_ + + +------------------------------------------------------------------------------ +-- | This function generates a random password reset token and stores it in +-- the database for the user. Call this function when a user forgets their +-- password. Then use the token to autogenerate a link that the user can +-- visit to reset their password. This function also sets a timestamp so the +-- reset token can be expired. +setPasswordResetToken :: Text -> Handler b (AuthManager b) (Maybe Text) +setPasswordResetToken login = do + tokBS <- liftIO . randomToken 40 =<< gets randomNumberGenerator + let token = decodeUtf8 tokBS + now <- liftIO getCurrentTime + success <- modPasswordResetToken login (Just token) (Just now) + return $ if success then Just token else Nothing + + +------------------------------------------------------------------------------ +-- | Clears a user's password reset token. Call this when the user +-- successfully changes their password to ensure that the password reset link +-- cannot be used again. +clearPasswordResetToken :: Text -> Handler b (AuthManager b) Bool +clearPasswordResetToken login = modPasswordResetToken login Nothing Nothing + + +------------------------------------------------------------------------------ +-- | Helper function used for setting and clearing the password reset token +-- and associated timestamp. +modPasswordResetToken :: Text + -> Maybe Text + -> Maybe UTCTime + -> Handler v (AuthManager v) Bool +modPasswordResetToken login token timestamp = do + res <- runMaybeT $ do + u <- MaybeT $ withBackend $ \b -> liftIO $ lookupByLogin b login + lift $ saveUser $ u + { userResetToken = token + , userResetRequestedAt = timestamp + } + return () + return $ maybe False (\_ -> True) res + + + diff --git a/src/Snap/Snaplet/Auth/SpliceHelpers.hs b/src/Snap/Snaplet/Auth/SpliceHelpers.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/SpliceHelpers.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| + + Some pre-packaged splices that add convenience to a Heist-enabled + application. + +-} + +module Snap.Snaplet.Auth.SpliceHelpers + ( addAuthSplices + , compiledAuthSplices + , userCSplices + , userISplices + , ifLoggedIn + , ifLoggedOut + , loggedInUser + , cIfLoggedIn + , cIfLoggedOut + , cLoggedInUser + ) where + +------------------------------------------------------------------------------ +import Control.Lens +import Control.Monad.Trans +import Data.Map.Syntax ((##), mapV) +import Data.Maybe +import qualified Data.Text as T +import Data.Text.Encoding +import qualified Text.XmlHtml as X +import Heist +import qualified Heist.Interpreted as I +import qualified Heist.Compiled as C +import Heist.Splices +import Snap.Snaplet +import Snap.Snaplet.Auth.AuthManager +import Snap.Snaplet.Auth.Handlers +import Snap.Snaplet.Auth.Types +import Snap.Snaplet.Heist + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | Add all standard auth splices to a Heist-enabled application. +-- +-- This adds the following splices: +-- \ +-- \ +-- \ +addAuthSplices + :: HasHeist b + => Snaplet (Heist b) + -> SnapletLens b (AuthManager b) + -- ^ A lens reference to 'AuthManager' + -> Initializer b v () +addAuthSplices h auth = addConfig h sc + where + sc = mempty & scInterpretedSplices .~ is + & scCompiledSplices .~ cs + is = do + "ifLoggedIn" ## ifLoggedIn auth + "ifLoggedOut" ## ifLoggedOut auth + "loggedInUser" ## loggedInUser auth + cs = compiledAuthSplices auth + + + +------------------------------------------------------------------------------ +-- | List containing compiled splices for ifLoggedIn, ifLoggedOut, and +-- loggedInUser. +compiledAuthSplices :: SnapletLens b (AuthManager b) + -> Splices (SnapletCSplice b) +compiledAuthSplices auth = do + "ifLoggedIn" ## cIfLoggedIn auth + "ifLoggedOut" ## cIfLoggedOut auth + "loggedInUser" ## cLoggedInUser auth + + +------------------------------------------------------------------------------ +-- | Function to generate interpreted splices from an AuthUser. +userISplices :: Monad m => AuthUser -> Splices (I.Splice m) +userISplices AuthUser{..} = do + "userId" ## I.textSplice $ maybe "-" unUid userId + "userLogin" ## I.textSplice userLogin + "userEmail" ## I.textSplice $ fromMaybe "-" userEmail + "userActive" ## I.textSplice $ T.pack $ show $ isNothing userSuspendedAt + "userLoginCount" ## I.textSplice $ T.pack $ show userLoginCount + "userFailedCount" ## I.textSplice $ T.pack $ show userFailedLoginCount + "userLoginAt" ## I.textSplice $ maybe "-" (T.pack . show) userCurrentLoginAt + "userLastLoginAt" ## I.textSplice $ maybe "-" (T.pack . show) userLastLoginAt + "userSuspendedAt" ## I.textSplice $ maybe "-" (T.pack . show) userSuspendedAt + "userLoginIP" ## I.textSplice $ maybe "-" decodeUtf8 userCurrentLoginIp + "userLastLoginIP" ## I.textSplice $ maybe "-" decodeUtf8 userLastLoginIp + "userIfActive" ## ifISplice $ isNothing userSuspendedAt + "userIfSuspended" ## ifISplice $ isJust userSuspendedAt + + +------------------------------------------------------------------------------ +-- | Compiled splices for AuthUser. +userCSplices :: Monad m => Splices (RuntimeSplice m AuthUser -> C.Splice m) +userCSplices = fields `mappend` ifs + where + fields = mapV (C.pureSplice . C.textSplice) $ do + "userId" ## maybe "-" unUid . userId + "userLogin" ## userLogin + "userEmail" ## fromMaybe "-" . userEmail + "userActive" ## T.pack . show . isNothing . userSuspendedAt + "userLoginCount" ## T.pack . show . userLoginCount + "userFailedCount" ## T.pack . show . userFailedLoginCount + "userLoginAt" ## maybe "-" (T.pack . show) . userCurrentLoginAt + "userLastLoginAt" ## maybe "-" (T.pack . show) . userLastLoginAt + "userSuspendedAt" ## maybe "-" (T.pack . show) . userSuspendedAt + "userLoginIP" ## maybe "-" decodeUtf8 . userCurrentLoginIp + "userLastLoginIP" ## maybe "-" decodeUtf8 . userLastLoginIp + ifs = do + "userIfActive" ## ifCSplice (isNothing . userSuspendedAt) + "userIfSuspended" ## ifCSplice (isJust . userSuspendedAt) + + +------------------------------------------------------------------------------ +-- | A splice that can be used to check for existence of a user. If a user is +-- present, this will run the contents of the node. +-- +-- > Show this when there is a logged in user +ifLoggedIn :: SnapletLens b (AuthManager b) -> SnapletISplice b +ifLoggedIn auth = do + chk <- lift $ withTop auth isLoggedIn + case chk of + True -> getParamNode >>= return . X.childNodes + False -> return [] + + +------------------------------------------------------------------------------ +-- | A splice that can be used to check for existence of a user. If a user is +-- present, this will run the contents of the node. +-- +-- > Show this when there is a logged in user +cIfLoggedIn :: SnapletLens b (AuthManager b) -> SnapletCSplice b +cIfLoggedIn auth = do + cs <- C.runChildren + return $ C.yieldRuntime $ do + chk <- lift $ withTop auth isLoggedIn + case chk of + True -> C.codeGen cs + False -> mempty + + +------------------------------------------------------------------------------ +-- | A splice that can be used to check for absence of a user. If a user is +-- not present, this will run the contents of the node. +-- +-- > Show this when there is a logged in user +ifLoggedOut :: SnapletLens b (AuthManager b) -> SnapletISplice b +ifLoggedOut auth = do + chk <- lift $ withTop auth isLoggedIn + case chk of + False -> getParamNode >>= return . X.childNodes + True -> return [] + + +------------------------------------------------------------------------------ +-- | A splice that can be used to check for absence of a user. If a user is +-- not present, this will run the contents of the node. +-- +-- > Show this when there is a logged in user +cIfLoggedOut :: SnapletLens b (AuthManager b) -> SnapletCSplice b +cIfLoggedOut auth = do + cs <- C.runChildren + return $ C.yieldRuntime $ do + chk <- lift $ withTop auth isLoggedIn + case chk of + False -> C.codeGen cs + True -> mempty + + +------------------------------------------------------------------------------- +-- | A splice that will simply print the current user's login, if +-- there is one. +loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b +loggedInUser auth = do + u <- lift $ withTop auth currentUser + maybe (return []) (I.textSplice . userLogin) u + + +------------------------------------------------------------------------------- +-- | A splice that will simply print the current user's login, if +-- there is one. +cLoggedInUser :: SnapletLens b (AuthManager b) -> SnapletCSplice b +cLoggedInUser auth = + return $ C.yieldRuntimeText $ do + u <- lift $ withTop auth currentUser + return $ maybe "" userLogin u diff --git a/src/Snap/Snaplet/Auth/Types.hs b/src/Snap/Snaplet/Auth/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Types.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Snap.Snaplet.Auth.Types where + +------------------------------------------------------------------------------ +import Control.Arrow +import Control.Monad.Trans +import Crypto.PasswordStore +import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.Configurator as C +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Hashable (Hashable) +import Data.Time +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Typeable +import Snap.Snaplet + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + + +------------------------------------------------------------------------------ +-- | Password is clear when supplied by the user and encrypted later when +-- returned from the db. +data Password = ClearText ByteString + | Encrypted ByteString + deriving (Read, Show, Ord, Eq) + + +------------------------------------------------------------------------------ +-- | Default strength level to pass into makePassword. +defaultStrength :: Int +defaultStrength = 12 + + +------------------------------------------------------------------------------- +-- | The underlying encryption function, in case you need it for +-- external processing. +encrypt :: ByteString -> IO ByteString +encrypt = flip makePassword defaultStrength + + +------------------------------------------------------------------------------- +-- | The underlying verify function, in case you need it for external +-- processing. +verify + :: ByteString -- ^ Cleartext + -> ByteString -- ^ Encrypted reference + -> Bool +verify = verifyPassword + + +------------------------------------------------------------------------------ +-- | Turn a 'ClearText' password into an 'Encrypted' password, ready to +-- be stuffed into a database. +encryptPassword :: Password -> IO Password +encryptPassword p@(Encrypted {}) = return p +encryptPassword (ClearText p) = Encrypted `fmap` encrypt p + + +------------------------------------------------------------------------------ +checkPassword :: Password -> Password -> Bool +checkPassword (ClearText pw) (Encrypted pw') = verify pw pw' +checkPassword (ClearText pw) (ClearText pw') = pw == pw' +checkPassword (Encrypted pw) (Encrypted pw') = pw == pw' +checkPassword _ _ = + error "checkPassword failed. Make sure you pass ClearText passwords" + + +------------------------------------------------------------------------------ +-- | Authentication failures indicate what went wrong during authentication. +-- They may provide useful information to the developer, although it is +-- generally not advisable to show the user the exact details about why login +-- failed. +data AuthFailure = AuthError String + | BackendError + | DuplicateLogin + | EncryptedPassword + | IncorrectPassword + | LockedOut UTCTime -- ^ Locked out until given time + | PasswordMissing + | UsernameMissing + | UserNotFound + deriving (Read, Ord, Eq, Typeable) + + +instance Show AuthFailure where + show (AuthError s) = s + show (BackendError) = "Failed to store data in the backend." + show (DuplicateLogin) = "This login already exists in the backend." + show (EncryptedPassword) = "Cannot login with encrypted password." + show (IncorrectPassword) = "The password provided was not valid." + show (LockedOut time) = "The login is locked out until " ++ show time + show (PasswordMissing) = "No password provided." + show (UsernameMissing) = "No username provided." + show (UserNotFound) = "User not found in the backend." + + +------------------------------------------------------------------------------ +-- | Internal representation of a 'User'. By convention, we demand that the +-- application is able to directly fetch a 'User' using this identifier. +-- +-- Think of this type as a secure, authenticated user. You should normally +-- never see this type unless a user has been authenticated. +newtype UserId = UserId { unUid :: Text } + deriving ( Read, Show, Ord, Eq, FromJSON, ToJSON, Hashable ) + +#if MIN_VERSION_aeson(1,0,0) +deriving instance FromJSONKey UserId +deriving instance ToJSONKey UserId +#endif + +------------------------------------------------------------------------------ +-- | This will be replaced by a role-based permission system. +data Role = Role ByteString + deriving (Read, Show, Ord, Eq) + + +------------------------------------------------------------------------------ +-- | Type representing the concept of a User in your application. +data AuthUser = AuthUser + { userId :: Maybe UserId + , userLogin :: Text + + -- We have to have an email field for password reset functionality, but we + -- don't want to force users to log in with their email address. + , userEmail :: Maybe Text + , userPassword :: Maybe Password + , userActivatedAt :: Maybe UTCTime + , userSuspendedAt :: Maybe UTCTime + , userRememberToken :: Maybe Text + , userLoginCount :: Int + , userFailedLoginCount :: Int + , userLockedOutUntil :: Maybe UTCTime + , userCurrentLoginAt :: Maybe UTCTime + , userLastLoginAt :: Maybe UTCTime + , userCurrentLoginIp :: Maybe ByteString + , userLastLoginIp :: Maybe ByteString + , userCreatedAt :: Maybe UTCTime + , userUpdatedAt :: Maybe UTCTime + , userResetToken :: Maybe Text + , userResetRequestedAt :: Maybe UTCTime + , userRoles :: [Role] + , userMeta :: HashMap Text Value + } + deriving (Show,Eq) + + +------------------------------------------------------------------------------ +-- | Default AuthUser that has all empty values. +defAuthUser :: AuthUser +defAuthUser = AuthUser + { userId = Nothing + , userLogin = "" + , userEmail = Nothing + , userPassword = Nothing + , userActivatedAt = Nothing + , userSuspendedAt = Nothing + , userRememberToken = Nothing + , userLoginCount = 0 + , userFailedLoginCount = 0 + , userLockedOutUntil = Nothing + , userCurrentLoginAt = Nothing + , userLastLoginAt = Nothing + , userCurrentLoginIp = Nothing + , userLastLoginIp = Nothing + , userCreatedAt = Nothing + , userUpdatedAt = Nothing + , userResetToken = Nothing + , userResetRequestedAt = Nothing + , userRoles = [] + , userMeta = HM.empty + } + + +------------------------------------------------------------------------------ +-- | Set a new password for the given user. Given password should be +-- clear-text; it will be encrypted into a 'Encrypted'. +setPassword :: AuthUser -> ByteString -> IO AuthUser +setPassword au pass = do + pw <- Encrypted <$> makePassword pass defaultStrength + return $! au { userPassword = Just pw } + + +------------------------------------------------------------------------------ +-- | Authentication settings defined at initialization time +data AuthSettings = AuthSettings { + asMinPasswdLen :: Int + -- ^ Currently not used/checked + + , asRememberCookieName :: ByteString + -- ^ Name of the desired remember cookie + + , asRememberPeriod :: Maybe Int + -- ^ How long to remember when the option is used in rest of the API. + -- 'Nothing' means remember until end of session. + + , asLockout :: Maybe (Int, NominalDiffTime) + -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration]) + + , asSiteKey :: FilePath + -- ^ Location of app's encryption key +} + + +------------------------------------------------------------------------------ +-- | Default settings for Auth. +-- +-- > asMinPasswdLen = 8 +-- > asRememberCookieName = "_remember" +-- > asRememberPeriod = Just (2*7*24*60*60) = 2 weeks +-- > asLockout = Nothing +-- > asSiteKey = "site_key.txt" +defAuthSettings :: AuthSettings +defAuthSettings = AuthSettings { + asMinPasswdLen = 8 + , asRememberCookieName = "_remember" + , asRememberPeriod = Just (2*7*24*60*60) + , asLockout = Nothing + , asSiteKey = "site_key.txt" +} + + +------------------------------------------------------------------------------ +-- | Function to get auth settings from a config file. This function can be +-- used by the authors of auth snaplet backends in the initializer to let the +-- user configure the auth snaplet from a config file. All options are +-- optional and default to what's in defAuthSettings if not supplied. +-- Here's what the default options would look like in the config file: +-- +-- > minPasswordLen = 8 +-- > rememberCookie = "_remember" +-- > rememberPeriod = 1209600 # 2 weeks +-- > lockout = [5, 86400] # 5 attempts locks you out for 86400 seconds +-- > siteKey = "site_key.txt" +authSettingsFromConfig :: Initializer b v AuthSettings +authSettingsFromConfig = do + config <- getSnapletUserConfig + minPasswordLen <- liftIO $ C.lookup config "minPasswordLen" + let pw = maybe id (\x s -> s { asMinPasswdLen = x }) minPasswordLen + rememberCookie <- liftIO $ C.lookup config "rememberCookie" + let rc = maybe id (\x s -> s { asRememberCookieName = x }) rememberCookie + rememberPeriod <- liftIO $ C.lookup config "rememberPeriod" + let rp = maybe id (\x s -> s { asRememberPeriod = Just x }) rememberPeriod + lockout <- liftIO $ C.lookup config "lockout" + let lo = maybe id (\x s -> s { asLockout = Just (second fromInteger x) }) + lockout + siteKey <- liftIO $ C.lookup config "siteKey" + let sk = maybe id (\x s -> s { asSiteKey = x }) siteKey + return $ (pw . rc . rp . lo . sk) defAuthSettings + + + -------------------- + -- JSON Instances -- + -------------------- + +------------------------------------------------------------------------------ +instance ToJSON AuthUser where + toJSON u = object + [ "uid" .= userId u + , "login" .= userLogin u + , "email" .= userEmail u + , "pw" .= userPassword u + , "activated_at" .= userActivatedAt u + , "suspended_at" .= userSuspendedAt u + , "remember_token" .= userRememberToken u + , "login_count" .= userLoginCount u + , "failed_login_count" .= userFailedLoginCount u + , "locked_until" .= userLockedOutUntil u + , "current_login_at" .= userCurrentLoginAt u + , "last_login_at" .= userLastLoginAt u + , "current_ip" .= fmap decodeUtf8 (userCurrentLoginIp u) + , "last_ip" .= fmap decodeUtf8 (userLastLoginIp u) + , "created_at" .= userCreatedAt u + , "updated_at" .= userUpdatedAt u + , "reset_token" .= userResetToken u + , "reset_requested_at" .= userResetRequestedAt u + , "roles" .= userRoles u + , "meta" .= userMeta u + ] + + +------------------------------------------------------------------------------ +instance FromJSON AuthUser where + parseJSON (Object v) = AuthUser + <$> v .: "uid" + <*> v .: "login" + <*> v .: "email" + <*> v .: "pw" + <*> v .: "activated_at" + <*> v .: "suspended_at" + <*> v .: "remember_token" + <*> v .: "login_count" + <*> v .: "failed_login_count" + <*> v .: "locked_until" + <*> v .: "current_login_at" + <*> v .: "last_login_at" + <*> fmap (fmap encodeUtf8) (v .: "current_ip") + <*> fmap (fmap encodeUtf8) (v .: "last_ip") + <*> v .: "created_at" + <*> v .: "updated_at" + <*> v .: "reset_token" + <*> v .: "reset_requested_at" + <*> v .:? "roles" .!= [] + <*> v .: "meta" + parseJSON _ = error "Unexpected JSON input" + + +------------------------------------------------------------------------------ +instance ToJSON Password where + toJSON (Encrypted x) = toJSON $ decodeUtf8 x + toJSON (ClearText _) = + error "ClearText passwords can't be serialized into JSON" + + +------------------------------------------------------------------------------ +instance FromJSON Password where + parseJSON = fmap (Encrypted . encodeUtf8) . parseJSON + + +------------------------------------------------------------------------------ +instance ToJSON Role where + toJSON (Role x) = toJSON $ decodeUtf8 x + + +------------------------------------------------------------------------------ +instance FromJSON Role where + parseJSON = fmap (Role . encodeUtf8) . parseJSON diff --git a/src/Snap/Snaplet/Config.hs b/src/Snap/Snaplet/Config.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Config.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Snap.Snaplet.Config where + +------------------------------------------------------------------------------ +import Data.Function (on) +import Data.Maybe (fromMaybe) +import Data.Monoid (Last(..), getLast) + +#if MIN_VERSION_base(4,10,0) +import Data.Typeable (Typeable) +#elif MIN_VERSION_base(4,7,0) +import Data.Typeable.Internal (Typeable) +#else +import Data.Typeable (Typeable, TyCon, mkTyCon, + mkTyConApp, typeOf) +#endif + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid, mappend, mempty) +#endif + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup(..)) +#endif + +import System.Console.GetOpt (OptDescr(Option), ArgDescr(ReqArg)) +------------------------------------------------------------------------------ +import Snap.Core +import Snap.Http.Server.Config (Config, fmapOpt, setOther, getOther, optDescrs + ,extendedCommandLineConfig) + + +------------------------------------------------------------------------------ +-- | AppConfig contains the config options for command line arguments in +-- snaplet-based apps. +newtype AppConfig = AppConfig { appEnvironment :: Maybe String } +#if MIN_VERSION_base(4,7,0) + deriving Typeable +#else + +------------------------------------------------------------------------------ +-- | AppConfig has a manual instance of Typeable due to limitations in the +-- tools available before GHC 7.4, and the need to make dynamic loading +-- tractable. When support for earlier versions of GHC is dropped, the +-- dynamic loader package can be updated so that manual Typeable instances +-- are no longer needed. +appConfigTyCon :: TyCon +appConfigTyCon = mkTyCon "Snap.Snaplet.Config.AppConfig" +{-# NOINLINE appConfigTyCon #-} + +instance Typeable AppConfig where + typeOf _ = mkTyConApp appConfigTyCon [] +#endif + +instance Semigroup AppConfig where + a <> b = AppConfig + { appEnvironment = ov appEnvironment a b + } + where + ov f x y = getLast $! ((<>) `on` (Last . f)) x y + + +------------------------------------------------------------------------------ +instance Monoid AppConfig where + mempty = AppConfig Nothing +#if !MIN_VERSION_base(4,11,0) + mappend = (<>) +#endif + + +------------------------------------------------------------------------------ +-- | Command line options for snaplet applications. +appOpts :: AppConfig -> [OptDescr (Maybe (Config m AppConfig))] +appOpts defaults = map (fmapOpt $ fmap (flip setOther mempty)) + [ Option ['e'] ["environment"] + (ReqArg setter "ENVIRONMENT") + $ "runtime environment to use" ++ defaultC appEnvironment + ] + where + setter s = Just $ mempty { appEnvironment = Just s} + defaultC f = maybe "" ((", default " ++) . show) $ f defaults + + +------------------------------------------------------------------------------ +-- | Calls snap-server's extendedCommandLineConfig to add snaplet options to +-- the built-in server command line options. +commandLineAppConfig :: MonadSnap m + => Config m AppConfig + -> IO (Config m AppConfig) +commandLineAppConfig defaults = + extendedCommandLineConfig (appOpts appDefaults ++ optDescrs defaults) + mappend defaults + where + appDefaults = fromMaybe mempty $ getOther defaults diff --git a/src/Snap/Snaplet/Heist.hs b/src/Snap/Snaplet/Heist.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Heist.hs @@ -0,0 +1,349 @@ +------------------------------------------------------------------------------ +-- | The Heist snaplet makes it easy to add Heist to your application and use +-- it in other snaplets. +-- + +module Snap.Snaplet.Heist + ( + -- * Heist and its type class + Heist + , HasHeist(..) + + -- * Initializer Functions + -- $initializerSection + , heistInit + , heistInit' + , Unclassed.heistReloader + , Unclassed.setInterpreted + , Unclassed.getCurHeistConfig + , addTemplates + , addTemplatesAt + , Unclassed.addConfig + , getHeistState + , modifyHeistState + , withHeistState + + -- * Handler Functions + -- $handlerSection + , gRender + , gRenderAs + , gHeistServe + , gHeistServeSingle + , chooseMode + + , cRender + , cRenderAs + , cHeistServe + , cHeistServeSingle + + , render + , renderAs + , heistServe + , heistServeSingle + , heistLocal + , withSplices + , renderWithSplices + + -- * Writing Splices + -- $spliceSection + , Unclassed.SnapletHeist + , Unclassed.SnapletCSplice + , Unclassed.SnapletISplice + + , clearHeistCache + ) where + +------------------------------------------------------------------------------ +import Prelude hiding (id, (.)) +import Control.Monad.State +import Data.ByteString (ByteString) +import Heist +------------------------------------------------------------------------------ +import Snap.Snaplet +import Snap.Snaplet.Heist.Internal +import qualified Snap.Snaplet.HeistNoClass as Unclassed +import Snap.Snaplet.HeistNoClass ( heistInit + , heistInit' + , clearHeistCache + ) + + +------------------------------------------------------------------------------ +-- | A single snaplet should never need more than one instance of Heist as a +-- subsnaplet. This type class allows you to make it easy for other snaplets +-- to get the lens that identifies the heist snaplet. Here's an example of +-- how the heist snaplet might be declared: +-- +-- > data App = App { _heist :: Snaplet (Heist App) } +-- > makeLenses ''App +-- > +-- > instance HasHeist App where heistLens = subSnaplet heist +-- > +-- > appInit = makeSnaplet "app" "" Nothing $ do +-- > h <- nestSnaplet "heist" heist $ heistInit "templates" +-- > addConfig h heistConfigWithMyAppSplices +-- > return $ App h +class HasHeist b where + -- | A lens to the Heist snaplet. The b parameter to Heist will + -- typically be the base state of your application. + heistLens :: SnapletLens (Snaplet b) (Heist b) + + +-- $initializerSection +-- This section contains functions for use in setting up your Heist state +-- during initialization. + + +------------------------------------------------------------------------------ +-- | Adds templates to the Heist HeistState. Other snaplets should use +-- this function to add their own templates. The templates are automatically +-- read from the templates directory in the current snaplet's filesystem root. +addTemplates :: HasHeist b + => Snaplet (Heist b) + -> ByteString + -- ^ The url prefix for the template routes + -> Initializer b v () +addTemplates h pfx = withTop' heistLens (Unclassed.addTemplates h pfx) + + +------------------------------------------------------------------------------ +-- | Adds templates to the Heist HeistState, and lets you specify where +-- they are found in the filesystem. Note that the path to the template +-- directory is an absolute path. This allows you more flexibility in where +-- your templates are located, but means that you have to explicitly call +-- getSnapletFilePath if you want your snaplet to use templates within its +-- normal directory structure. +addTemplatesAt :: HasHeist b + => Snaplet (Heist b) + -> ByteString + -- ^ URL prefix for template routes + -> FilePath + -- ^ Path to templates + -> Initializer b v () +addTemplatesAt h pfx p = + withTop' heistLens (Unclassed.addTemplatesAt h pfx p) + + +------------------------------------------------------------------------------ +-- | More general function allowing arbitrary HeistState modification. +getHeistState :: (HasHeist b) + => Handler b v (HeistState (Handler b b)) +getHeistState = Unclassed.getHeistState heistLens + + +------------------------------------------------------------------------------ +-- | More general function allowing arbitrary HeistState modification. +modifyHeistState :: (HasHeist b) + => (HeistState (Handler b b) -> HeistState (Handler b b)) + -- ^ HeistState modifying function + -> Initializer b v () +modifyHeistState = Unclassed.modifyHeistState' heistLens + + +------------------------------------------------------------------------------ +-- | Runs a function on with the Heist snaplet's 'HeistState'. +withHeistState :: (HasHeist b) + => (HeistState (Handler b b) -> a) + -- ^ HeistState function to run + -> Handler b v a +withHeistState = Unclassed.withHeistState' heistLens + + +-- $handlerSection +-- This section contains functions in the 'Handler' monad that you'll use in +-- processing requests. Functions beginning with a 'g' prefix use generic +-- rendering that checks the preferred rendering mode and chooses +-- appropriately. Functions beginning with a 'c' prefix use compiled template +-- rendering. The other functions use the older interpreted rendering. +-- Interpreted splices added with addConfig will only work if you use +-- interpreted rendering. +-- +-- The generic functions are useful if you are writing general snaplets that +-- use heist, but need to work for applications that use either interpreted +-- or compiled mode. + + +------------------------------------------------------------------------------ +-- | Generic version of 'render'/'cRender'. +gRender :: HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +gRender t = withTop' heistLens (Unclassed.gRender t) + + +------------------------------------------------------------------------------ +-- | Generic version of 'renderAs'/'cRenderAs'. +gRenderAs :: HasHeist b + => ByteString + -- ^ Content type to render with + -> ByteString + -- ^ Template name + -> Handler b v () +gRenderAs ct t = withTop' heistLens (Unclassed.gRenderAs ct t) + + +------------------------------------------------------------------------------ +-- | Generic version of 'heistServe'/'cHeistServe'. +gHeistServe :: HasHeist b => Handler b v () +gHeistServe = withTop' heistLens Unclassed.gHeistServe + + +------------------------------------------------------------------------------ +-- | Generic version of 'heistServeSingle'/'cHeistServeSingle'. +gHeistServeSingle :: HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +gHeistServeSingle t = withTop' heistLens (Unclassed.gHeistServeSingle t) + + +------------------------------------------------------------------------------ +-- | Chooses between a compiled action and an interpreted action based on the +-- configured default. +chooseMode :: HasHeist b + => Handler b v a + -- ^ A compiled action + -> Handler b v a + -- ^ An interpreted action + -> Handler b v a +chooseMode cAction iAction = do + mode <- withTop' heistLens $ gets _defMode + case mode of + Unclassed.Compiled -> cAction + Unclassed.Interpreted -> iAction + + +------------------------------------------------------------------------------ +-- | Renders a compiled template as text\/html. If the given template is not +-- found, this returns 'empty'. +cRender :: HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +cRender t = withTop' heistLens (Unclassed.cRender t) + + +------------------------------------------------------------------------------ +-- | Renders a compiled template as the given content type. If the given +-- template is not found, this returns 'empty'. +cRenderAs :: HasHeist b + => ByteString + -- ^ Content type to render with + -> ByteString + -- ^ Template name + -> Handler b v () +cRenderAs ct t = withTop' heistLens (Unclassed.cRenderAs ct t) + + +------------------------------------------------------------------------------ +-- | A compiled version of 'heistServe'. +cHeistServe :: HasHeist b => Handler b v () +cHeistServe = withTop' heistLens Unclassed.cHeistServe + + +------------------------------------------------------------------------------ +-- | Analogous to 'fileServeSingle'. If the given template is not found, +-- this throws an error. +cHeistServeSingle :: HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +cHeistServeSingle t = withTop' heistLens (Unclassed.cHeistServeSingle t) + + +------------------------------------------------------------------------------ +-- | Renders a template as text\/html. If the given template is not found, +-- this returns 'empty'. +render :: HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +render t = withTop' heistLens (Unclassed.render t) + + +------------------------------------------------------------------------------ +-- | Renders a template as the given content type. If the given template +-- is not found, this returns 'empty'. +renderAs :: HasHeist b + => ByteString + -- ^ Content type to render with + -> ByteString + -- ^ Template name + -> Handler b v () +renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t) + + +------------------------------------------------------------------------------ +-- | A handler that serves all the templates (similar to 'serveDirectory'). +-- If the template specified in the request path is not found, it returns +-- 'empty'. Also, this function does not serve any templates beginning with +-- an underscore. This gives you a way to prevent some templates from being +-- served. For example, you might have a template that contains only the +-- navbar of your pages, and you probably wouldn't want that template to be +-- visible to the user as a standalone template. So if you put it in a file +-- called \"_nav.tpl\", this function won't serve it. +heistServe :: HasHeist b => Handler b v () +heistServe = withTop' heistLens Unclassed.heistServe + + +------------------------------------------------------------------------------ +-- | Handler for serving a single template (similar to 'fileServeSingle'). If +-- the given template is not found, this throws an error. +heistServeSingle :: HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t) + + +------------------------------------------------------------------------------ +-- | Renders a template with a given set of splices. This is syntax sugar for +-- a common combination of heistLocal, bindSplices, and render. +renderWithSplices :: HasHeist b + => ByteString + -- ^ Template name + -> Splices (Unclassed.SnapletISplice b) + -- ^ Splices to bind + -> Handler b v () +renderWithSplices = Unclassed.renderWithSplices' heistLens + + +------------------------------------------------------------------------------ +-- | Runs an action with additional splices bound into the Heist +-- 'HeistState'. +withSplices :: HasHeist b + => Splices (Unclassed.SnapletISplice b) + -- ^ Splices to bind + -> Handler b v a + -- ^ Handler to run + -> Handler b v a +withSplices = Unclassed.withSplices' heistLens + + +------------------------------------------------------------------------------ +-- | Runs a handler with a modified 'HeistState'. You might want to use +-- this if you had a set of splices which were customised for a specific +-- action. To do that you would do: +-- +-- > heistLocal (bindSplices mySplices) handlerThatNeedsSplices +heistLocal :: HasHeist b + => (HeistState (Handler b b) -> HeistState (Handler b b)) + -- ^ HeistState modifying function + -> Handler b v a + -- ^ Handler to run + -> Handler b v a +heistLocal = Unclassed.heistLocal' heistLens + + +-- $spliceSection +-- The type signature for SnapletHeist uses @(Handler b b)@ as the Heist +-- snaplet's runtime monad. This means that your splices must use the +-- top-level snaplet's @Handler b b@ monad. The reasons for this are beyond +-- the scope of this discussion, but the result is that 'lift' inside a splice +-- only works with @Handler b b@ actions. When you're writing your own +-- snaplets using some snaplet-specific monad @Handler b v@ you still have to +-- use @Handler b b@ for your splices. If the splices need any of the context +-- provided by the @v@, you must pass it in as a parameter to the splice +-- function. + diff --git a/src/Snap/Snaplet/Heist/Compiled.hs b/src/Snap/Snaplet/Heist/Compiled.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Heist/Compiled.hs @@ -0,0 +1,98 @@ +{-| + +A module exporting only functions for using compiled templates. If you +import the main Snap.Snaplet.Heist module, it's easy to accidentally use +the interpreted render function even when you're using compiled Heist. +Importing only this module will make it harder to make mistakes like that. + +-} +module Snap.Snaplet.Heist.Compiled + ( H.Heist + , H.HasHeist(..) + , H.SnapletHeist + , H.SnapletCSplice + + -- * Initializer Functions + -- $initializerSection + , heistInit + , H.heistInit' + , H.heistReloader + , H.addTemplates + , H.addTemplatesAt + , H.addConfig + , H.getHeistState + , H.modifyHeistState + , H.withHeistState + + -- * Handler Functions + -- $handlerSection + , render + , renderAs + , heistServe + , heistServeSingle + + , H.clearHeistCache + ) where + +import Data.ByteString (ByteString) +import Snap.Snaplet +import Snap.Snaplet.Heist.Internal +import qualified Snap.Snaplet.Heist as H +import qualified Snap.Snaplet.HeistNoClass as HNC + + +------------------------------------------------------------------------------ +-- | The 'Initializer' for 'Heist'. This function is a convenience wrapper +-- around `heistInit'` that uses defaultHeistState and sets up routes for all +-- the templates. It sets up a \"heistReload\" route that reloads the heist +-- templates when you request it from localhost. +heistInit :: FilePath + -- ^ Path to templates + -> SnapletInit b (Heist b) +heistInit = gHeistInit HNC.cHeistServe + + +------------------------------------------------------------------------------ +-- | Renders a compiled template as text\/html. If the given template is not +-- found, this returns 'empty'. +render :: H.HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +render = H.cRender + + +------------------------------------------------------------------------------ +-- | Renders a compiled template as the given content type. If the given +-- template is not found, this returns 'empty'. +renderAs :: H.HasHeist b + => ByteString + -- ^ Content type to render with + -> ByteString + -- ^ Template name + -> Handler b v () +renderAs = H.cRenderAs + + +------------------------------------------------------------------------------ +-- | A handler that serves all the templates (similar to 'serveDirectory'). +-- If the template specified in the request path is not found, it returns +-- 'empty'. Also, this function does not serve any templates beginning with +-- an underscore. This gives you a way to prevent some templates from being +-- served. For example, you might have a template that contains only the +-- navbar of your pages, and you probably wouldn't want that template to be +-- visible to the user as a standalone template. So if you put it in a file +-- called \"_nav.tpl\", this function won't serve it. +heistServe :: H.HasHeist b => Handler b v () +heistServe = H.cHeistServe + + +------------------------------------------------------------------------------ +-- | Handler for serving a single template (similar to 'fileServeSingle'). If +-- the given template is not found, this throws an error. +heistServeSingle :: H.HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +heistServeSingle = H.cHeistServeSingle + diff --git a/src/Snap/Snaplet/Heist/Generic.hs b/src/Snap/Snaplet/Heist/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Heist/Generic.hs @@ -0,0 +1,36 @@ +{-| + +A module exporting only generic functions that choose between compiled and +interpreted mode based on the setting specified in the initializer. This +module is most useful for writitng general snaplets that use Heist and are +meant to be used in applications that might use either interpreted or compiled +templates. + +-} +module Snap.Snaplet.Heist.Generic + ( Heist + , HasHeist(..) + , SnapletHeist + , SnapletCSplice + + -- * Initializer Functions + -- $initializerSection + , addTemplates + , addTemplatesAt + , addConfig + , getHeistState + , modifyHeistState + , withHeistState + + -- * Handler Functions + -- $handlerSection + , gRender + , gRenderAs + , gHeistServe + , gHeistServeSingle + , chooseMode + + , clearHeistCache + ) where + +import Snap.Snaplet.Heist diff --git a/src/Snap/Snaplet/Heist/Internal.hs b/src/Snap/Snaplet/Heist/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Heist/Internal.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE TemplateHaskell #-} +module Snap.Snaplet.Heist.Internal where + +import Prelude +import Control.Lens +import Control.Monad (liftM) +import Control.Monad.State +import qualified Data.ByteString as B +import Data.Char +import qualified Data.HashMap.Strict as Map +import Data.IORef +import Data.List +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Heist +import Heist.Splices.Cache +import System.FilePath.Posix + +import Snap.Core +import Snap.Snaplet + + +data DefaultMode = Compiled | Interpreted + + +------------------------------------------------------------------------------ +-- | The state for the Heist snaplet. To use the Heist snaplet in your app +-- include this in your application state and use 'heistInit' to initialize +-- it. The type parameter b will typically be the base state type for your +-- application. +data Heist b = Configuring + { _heistConfig :: IORef (HeistConfig (Handler b b), DefaultMode) + } + | Running + { _masterConfig :: HeistConfig (Handler b b) + , _heistState :: HeistState (Handler b b) + , _heistCTS :: CacheTagState + , _defMode :: DefaultMode + } + +makeLenses ''Heist + + +------------------------------------------------------------------------------ +-- | Generic initializer function that allows compiled/interpreted template +-- serving to be specified by the caller. +gHeistInit :: Handler b (Heist b) () + -> FilePath + -> SnapletInit b (Heist b) +gHeistInit serve templateDir = do + makeSnaplet "heist" "" Nothing $ do + hs <- heistInitWorker templateDir defaultConfig + addRoutes [ ("", serve) + , ("heistReload", failIfNotLocal heistReloader) + ] + return hs + where + sc = set scLoadTimeSplices defaultLoadTimeSplices mempty + defaultConfig = emptyHeistConfig & hcSpliceConfig .~ sc + & hcNamespace .~ "" + & hcErrorNotBound .~ True + + +------------------------------------------------------------------------------ +-- | Internal worker function used by variants of heistInit. This is +-- necessary because of the divide between SnapletInit and Initializer. +heistInitWorker :: FilePath + -> HeistConfig (Handler b b) + -> Initializer b (Heist b) (Heist b) +heistInitWorker templateDir initialConfig = do + snapletPath <- getSnapletFilePath + let tDir = snapletPath templateDir + templates <- liftIO $ (loadTemplates tDir) >>= + either (error . concat) return + printInfo $ T.pack $ unwords + [ "...loaded" + , (show $ Map.size templates) + , "templates from" + , tDir + ] + let config = initialConfig & hcTemplateLocations %~ + (<> [loadTemplates tDir]) + & hcCompiledTemplateFilter %~ + (\f x -> f x && nsFilter x) + + ref <- liftIO $ newIORef (config, Compiled) + + -- FIXME This runs after all the initializers, but before post init + -- hooks registered by other snaplets. + addPostInitHook finalLoadHook + return $ Configuring ref + where + nsFilter = (/=) (fromIntegral $ ord '_') . B.head . head + + +------------------------------------------------------------------------------ +-- | Hook that converts the Heist type from Configuring to Running at the end +-- of initialization. +finalLoadHook :: Heist b -> IO (Either Text (Heist b)) +finalLoadHook (Configuring ref) = do + (hc,dm) <- readIORef ref + res <- liftM toTextErrors $ initHeistWithCacheTag hc + return $ case res of + Left e -> Left e + Right (hs,cts) -> Right $ Running hc hs cts dm + where + toTextErrors = mapBoth (T.pack . intercalate "\n") id +finalLoadHook (Running _ _ _ _) = + return $ Left "finalLoadHook called while running" + + +mapBoth :: (a -> c) -> (b -> d) -> Either a b -> Either c d +mapBoth f _ (Left x) = Left (f x) +mapBoth _ f (Right x) = Right (f x) + + +------------------------------------------------------------------------------ +-- | Handler that triggers a template reload. For large sites, this can be +-- desireable because it may be much quicker than the full site reload +-- provided at the /admin/reload route. This allows you to reload only the +-- heist templates This handler is automatically set up by heistInit, but if +-- you use heistInit', then you can create your own route with it. +heistReloader :: Handler b (Heist b) () +heistReloader = do + h <- get + ehs <- liftIO $ initHeist $ _masterConfig h + either (writeText . T.pack . unlines) + (\hs -> do writeText "Heist reloaded." + modifyMaster $ set heistState hs h) + ehs diff --git a/src/Snap/Snaplet/Heist/Interpreted.hs b/src/Snap/Snaplet/Heist/Interpreted.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Heist/Interpreted.hs @@ -0,0 +1,40 @@ +{-| + +A module exporting only functions for using interpreted templates. If +you import the main Snap.Snaplet.Heist module, it's easy to accidentally +use the compiled render function even when you're using interpreted Heist. +Importing only this module will make it harder to make mistakes like that. + +-} +module Snap.Snaplet.Heist.Interpreted + ( Heist + , HasHeist(..) + , SnapletHeist + , SnapletISplice + + -- * Initializer Functions + -- $initializerSection + , heistInit + , heistInit' + , addTemplates + , addTemplatesAt + , addConfig + , getHeistState + , modifyHeistState + , withHeistState + + -- * Handler Functions + -- $handlerSection + , render + , renderAs + , heistServe + , heistServeSingle + , heistLocal + , withSplices + , renderWithSplices + + , clearHeistCache + ) where + +import Snap.Snaplet.Heist + diff --git a/src/Snap/Snaplet/HeistNoClass.hs b/src/Snap/Snaplet/HeistNoClass.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/HeistNoClass.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-| + +This module implements the Heist snaplet without using type classes. It is +provided mainly as an example of how snaplets can be written with and without +a type class for convenience. + +-} +module Snap.Snaplet.HeistNoClass + ( Heist + , DefaultMode(..) + , heistInit + , heistInit' + , heistReloader + , setInterpreted + , getCurHeistConfig + , clearHeistCache + + , addTemplates + , addTemplatesAt + , getHeistState + , modifyHeistState + , modifyHeistState' + , withHeistState + , withHeistState' + + , gRender + , gRenderAs + , gHeistServe + , gHeistServeSingle + , chooseMode + + , addConfig + , cRender + , cRenderAs + , cHeistServe + , cHeistServeSingle + + , render + , renderAs + , heistServe + , heistServeSingle + , heistLocal + , withSplices + , renderWithSplices + , heistLocal' + , withSplices' + , renderWithSplices' + + , SnapletHeist + , SnapletISplice + , SnapletCSplice + ) where + +import Prelude hiding ((.), id) +import Control.Applicative +import Control.Category +import Control.Lens +import Control.Monad.Reader +import Control.Monad.State +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.DList (DList) +import qualified Data.HashMap.Strict as Map +import Data.IORef +import Data.Maybe +import qualified Data.Text as T +import Data.Text.Encoding +import System.FilePath.Posix +import Heist +import qualified Heist.Compiled as C +import qualified Heist.Interpreted as I +import Heist.Splices.Cache + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + +import Snap.Snaplet +import Snap.Snaplet.Heist.Internal +import Snap.Core +import Snap.Util.FileServe + + +------------------------------------------------------------------------------ +changeState :: (HeistState (Handler a a) -> HeistState (Handler a a)) + -> Heist a + -> Heist a +changeState _ (Configuring _) = + error "changeState: HeistState has not been initialized" +changeState f (Running hc hs cts dm) = Running hc (f hs) cts dm + + +------------------------------------------------------------------------------ +-- | Clears data stored by the cache tag. The cache tag automatically reloads +-- its data when the specified TTL expires, but sometimes you may want to +-- trigger a manual reload. This function lets you do that. +clearHeistCache :: Heist b -> IO () +clearHeistCache = clearCacheTagState . _heistCTS + + + ----------------------------- + -- SnapletSplice functions -- + ----------------------------- + +------------------------------------------------------------------------------ +-- | This instance is here because we don't want the heist package to depend +-- on anything from snap packages. +instance MonadSnap m => MonadSnap (HeistT n m) where + liftSnap = lift . liftSnap + + +type SnapletHeist b m a = HeistT (Handler b b) m a +type SnapletCSplice b = SnapletHeist b IO (DList (Chunk (Handler b b))) +type SnapletISplice b = SnapletHeist b (Handler b b) Template + + + --------------------------- + -- Initializer functions -- + --------------------------- + + +------------------------------------------------------------------------------ +-- | The 'Initializer' for 'Heist'. This function is a convenience wrapper +-- around `heistInit'` that uses defaultHeistState and sets up routes for all +-- the templates. It sets up a \"heistReload\" route that reloads the heist +-- templates when you request it from localhost. +heistInit :: FilePath + -- ^ Path to templates + -> SnapletInit b (Heist b) +heistInit = gHeistInit heistServe + + +------------------------------------------------------------------------------ +-- | A lower level 'Initializer' for 'Heist'. This initializer requires you +-- to specify the initial HeistConfig. It also does not add any routes for +-- templates, allowing you complete control over which templates get routed. +heistInit' :: FilePath + -- ^ Path to templates + -> HeistConfig (Handler b b) + -- ^ Initial HeistConfig + -> SnapletInit b (Heist b) +heistInit' templateDir initialConfig = + makeSnaplet "heist" "" Nothing $ heistInitWorker templateDir initialConfig + + +------------------------------------------------------------------------------ +-- | Sets the snaplet to default to interpreted mode. Initially, the +-- initializer sets the value to compiled mode. This function allows you to +-- override that setting. Note that this is just a default. It only has an +-- effect if you use one of the generic functions: 'gRender', 'gRenderAs', +-- 'gHeistServe', or 'gHeistServeSingle'. If you call the non-generic +-- versions directly, then this value will not be checked and you will get the +-- mode implemented by the function you called. +setInterpreted :: Snaplet (Heist b) -> Initializer b v () +setInterpreted h = + liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) + (\(hc,_) -> ((hc,Interpreted),())) + + +------------------------------------------------------------------------------ +-- | Adds templates to the Heist HeistConfig. Other snaplets should use +-- this function to add their own templates. The templates are automatically +-- read from the templates directory in the current snaplet's filesystem root. +addTemplates :: Snaplet (Heist b) + -> ByteString + -- ^ The url prefix for the template routes + -> Initializer b (Heist b) () +addTemplates h urlPrefix = do + snapletPath <- getSnapletFilePath + addTemplatesAt h urlPrefix (snapletPath "templates") + + +------------------------------------------------------------------------------ +-- | Adds templates to the Heist HeistConfig, and lets you specify where +-- they are found in the filesystem. Note that the path to the template +-- directory is an absolute path. This allows you more flexibility in where +-- your templates are located, but means that you have to explicitly call +-- getSnapletFilePath if you want your snaplet to use templates within its +-- normal directory structure. +addTemplatesAt :: Snaplet (Heist b) + -> ByteString + -- ^ URL prefix for template routes + -> FilePath + -- ^ Path to templates + -> Initializer b (Heist b) () +addTemplatesAt h urlPrefix templateDir = do + rootUrl <- getSnapletRootURL + let fullPrefix = (T.unpack $ decodeUtf8 rootUrl) + (T.unpack $ decodeUtf8 urlPrefix) + addPrefix = addTemplatePathPrefix + (encodeUtf8 $ T.pack fullPrefix) + ts <- liftIO $ (loadTemplates templateDir) >>= + either (error . concat) return + printInfo $ T.pack $ unwords + [ "...adding" + , (show $ Map.size ts) + , "templates from" + , templateDir + , "with route prefix" + , fullPrefix ++ "/" + ] + let locations = [fmap addPrefix <$> loadTemplates templateDir] + add (hc, dm) = + ((over hcTemplateLocations (mappend locations) hc, dm), ()) + liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) add + + +getCurHeistConfig :: Snaplet (Heist b) + -> Initializer b v (HeistConfig (Handler b b)) +getCurHeistConfig h = case view snapletValue h of + Configuring ref -> do + (hc, _) <- liftIO $ readIORef ref + return hc + Running _ _ _ _ -> + error "Can't get HeistConfig after heist is initialized." + + +------------------------------------------------------------------------------ +getHeistState :: SnapletLens (Snaplet b) (Heist b) + -> Handler b v (HeistState (Handler b b)) +getHeistState heist = withTop' heist $ gets _heistState + + +------------------------------------------------------------------------------ +modifyHeistState' :: SnapletLens (Snaplet b) (Heist b) + -> (HeistState (Handler b b) -> HeistState (Handler b b)) + -> Initializer b v () +modifyHeistState' heist f = do + withTop' heist $ addPostInitHook $ return . Right . changeState f + + +------------------------------------------------------------------------------ +modifyHeistState :: SnapletLens b (Heist b) + -> (HeistState (Handler b b) -> HeistState (Handler b b)) + -> Initializer b v () +modifyHeistState heist f = modifyHeistState' (subSnaplet heist) f + + +------------------------------------------------------------------------------ +withHeistState' :: SnapletLens (Snaplet b) (Heist b) + -> (HeistState (Handler b b) -> a) + -> Handler b v a +withHeistState' heist f = do + hs <- withTop' heist $ gets _heistState + return $ f hs + + +------------------------------------------------------------------------------ +withHeistState :: SnapletLens b (Heist b) + -> (HeistState (Handler b b) -> a) + -> Handler b v a +withHeistState heist f = withHeistState' (subSnaplet heist) f + + +------------------------------------------------------------------------------ +-- | Adds more HeistConfig data using mappend with whatever is currently +-- there. This is the preferred method for adding all four kinds of splices +-- as well as new templates. +addConfig :: Snaplet (Heist b) + -> SpliceConfig (Handler b b) + -> Initializer b v () +addConfig h sc = case view snapletValue h of + Configuring ref -> + liftIO $ atomicModifyIORef ref add + Running _ _ _ _ -> do + printInfo "finalLoadHook called while running" + error "this shouldn't happen" + where + add (hc, dm) = + ((over hcSpliceConfig (`mappend` sc) hc, dm), ()) + + + ----------------------- + -- Handler functions -- + ----------------------- + +------------------------------------------------------------------------------ +-- | Internal helper function for rendering. +iRenderHelper :: Maybe MIMEType + -> ByteString + -> Handler b (Heist b) () +iRenderHelper c t = do + (Running _ hs _ _) <- get + withTop' id $ I.renderTemplate hs t >>= maybe pass serve + where + serve (b, mime) = do + modifyResponse $ setContentType $ fromMaybe mime c + writeBuilder b + + +------------------------------------------------------------------------------ +-- | Internal helper function for rendering. +cRenderHelper :: Maybe MIMEType + -> ByteString + -> Handler b (Heist b) () +cRenderHelper c t = do + (Running _ hs _ _) <- get + withTop' id $ maybe pass serve $ C.renderTemplate hs t + where + serve (b, mime) = do + modifyResponse $ setContentType $ fromMaybe mime c + writeBuilder =<< b + + +------------------------------------------------------------------------------ +serveURI :: Handler b (Heist b) ByteString +serveURI = do + p <- getSafePath + -- Allows users to prefix template filenames with an underscore to prevent + -- the template from being served. + if take 1 p == "_" then pass else return $ B.pack p + + +------------------------------------------------------------------------------ +render :: ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +render t = iRenderHelper Nothing t + + +------------------------------------------------------------------------------ +renderAs :: ByteString + -- ^ Content type + -> ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +renderAs ct t = iRenderHelper (Just ct) t + + +------------------------------------------------------------------------------ +heistServe :: Handler b (Heist b) () +heistServe = + ifTop (render "index") <|> (render =<< serveURI) + + +------------------------------------------------------------------------------ +heistServeSingle :: ByteString -> Handler b (Heist b) () +heistServeSingle t = + render t <|> error ("Template " ++ show t ++ " not found.") + + +------------------------------------------------------------------------------ +cRender :: ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +cRender t = cRenderHelper Nothing t + + +------------------------------------------------------------------------------ +cRenderAs :: ByteString + -- ^ Content type + -> ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +cRenderAs ct t = cRenderHelper (Just ct) t + + +------------------------------------------------------------------------------ +cHeistServe :: Handler b (Heist b) () +cHeistServe = + ifTop (cRender "index") <|> (cRender =<< serveURI) + + +------------------------------------------------------------------------------ +cHeistServeSingle :: ByteString -> Handler b (Heist b) () +cHeistServeSingle t = + cRender t <|> error ("Template " ++ show t ++ " not found.") + + +------------------------------------------------------------------------------ +-- | Chooses between a compiled action and an interpreted action based on the +-- configured default. +chooseMode :: MonadState (Heist b1) m + => m b + -- ^ A compiled action + -> m b + -- ^ An interpreted action + -> m b +chooseMode cAction iAction = do + mode <- gets _defMode + case mode of + Compiled -> cAction + Interpreted -> iAction + + +------------------------------------------------------------------------------ +-- | Like render/cRender, but chooses between the two appropriately based on +-- the default mode. +gRender :: ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +gRender t = chooseMode (cRender t) (render t) + + +------------------------------------------------------------------------------ +-- | Like renderAs/cRenderAs, but chooses between the two appropriately based +-- on the default mode. +gRenderAs :: ByteString + -- ^ Content type + -> ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +gRenderAs ct t = chooseMode (cRenderAs ct t) (renderAs ct t) + + +------------------------------------------------------------------------------ +-- | Like heistServe/cHeistServe, but chooses between the two appropriately +-- based on the default mode. +gHeistServe :: Handler b (Heist b) () +gHeistServe = chooseMode cHeistServe heistServe + + +------------------------------------------------------------------------------ +-- | Like heistServeSingle/cHeistServeSingle, but chooses between the two +-- appropriately based on the default mode. +gHeistServeSingle :: ByteString -> Handler b (Heist b) () +gHeistServeSingle t = chooseMode (cHeistServeSingle t) (heistServeSingle t) + + +------------------------------------------------------------------------------ +heistLocal' :: SnapletLens (Snaplet b) (Heist b) + -> (HeistState (Handler b b) -> HeistState (Handler b b)) + -> Handler b v a + -> Handler b v a +heistLocal' heist f m = do + hs <- withTop' heist get + withTop' heist $ modify $ changeState f + res <- m + withTop' heist $ put hs + return res + + +------------------------------------------------------------------------------ +heistLocal :: SnapletLens b (Heist b) + -> (HeistState (Handler b b) -> HeistState (Handler b b)) + -> Handler b v a + -> Handler b v a +heistLocal heist f m = heistLocal' (subSnaplet heist) f m + + +------------------------------------------------------------------------------ +withSplices' :: SnapletLens (Snaplet b) (Heist b) + -> Splices (SnapletISplice b) + -> Handler b v a + -> Handler b v a +withSplices' heist splices m = do + heistLocal' heist (I.bindSplices splices) m + + +------------------------------------------------------------------------------ +withSplices :: SnapletLens b (Heist b) + -> Splices (SnapletISplice b) + -> Handler b v a + -> Handler b v a +withSplices heist splices m = withSplices' (subSnaplet heist) splices m + + +------------------------------------------------------------------------------ +renderWithSplices' :: SnapletLens (Snaplet b) (Heist b) + -> ByteString + -> Splices (SnapletISplice b) + -> Handler b v () +renderWithSplices' heist t splices = + withSplices' heist splices $ withTop' heist $ render t + + +------------------------------------------------------------------------------ +renderWithSplices :: SnapletLens b (Heist b) + -> ByteString + -> Splices (SnapletISplice b) + -> Handler b v () +renderWithSplices heist t splices = + renderWithSplices' (subSnaplet heist) t splices diff --git a/src/Snap/Snaplet/Internal/Initializer.hs b/src/Snap/Snaplet/Internal/Initializer.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Internal/Initializer.hs @@ -0,0 +1,705 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Snap.Snaplet.Internal.Initializer + ( addPostInitHook + , addPostInitHookBase + , toSnapletHook + , bracketInit + , modifyCfg + , nestSnaplet + , embedSnaplet + , makeSnaplet + , nameSnaplet + , onUnload + , addRoutes + , wrapSite + , runInitializer + , runSnaplet + , combineConfig + , serveSnaplet + , serveSnapletNoArgParsing + , loadAppConfig + , printInfo + , getRoutes + , getEnvironment + , modifyMaster + ) where + +------------------------------------------------------------------------------ +import Control.Applicative ((<$>)) +import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, + putMVar, readMVar) +import Control.Exception.Lifted (SomeException, catch, try) +import Control.Lens (ALens', cloneLens, over, set, + storing, (^#)) +import Control.Monad (Monad (..), join, liftM, unless, + when, (=<<)) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, modify) +import Control.Monad.Trans (lift, liftIO) +import Control.Monad.Trans.Writer hiding (pass) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Configurator (Worth (..), addToConfig, empty, + loadGroups, subconfig) +import qualified Data.Configurator.Types as C +import Data.IORef (IORef, atomicModifyIORef, + newIORef, readIORef) +import Data.Maybe (Maybe (..), fromJust, fromMaybe, + isNothing) +import Data.Text (Text) +import qualified Data.Text as T +import Prelude (Bool (..), Either (..), Eq (..), + String, concat, concatMap, + const, either, + error, filter, flip, fst, id, + map, not, show, ($), ($!), (++), + (.)) +import Snap.Core (Snap, liftSnap, route) +import Snap.Http.Server (Config, completeConfig, + getCompression, getErrorHandler, + getOther, getVerbose, httpServe) +import Snap.Util.GZip (withCompression) +import System.Directory (copyFile, + createDirectoryIfMissing, + doesDirectoryExist, + getCurrentDirectory) +import System.Directory.Tree (DirTree (..), FileName, buildL, + dirTree, readDirectoryWith) +import System.FilePath.Posix (dropFileName, makeRelative, + ()) +import System.IO (FilePath, IO, hPutStrLn, stderr) +------------------------------------------------------------------------------ +import Snap.Snaplet.Config (AppConfig, appEnvironment, + commandLineAppConfig) +import qualified Snap.Snaplet.Internal.Lensed as L +import qualified Snap.Snaplet.Internal.LensT as LT +import Snap.Snaplet.Internal.Types +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | 'get' for InitializerState. +iGet :: Initializer b v (InitializerState b) +iGet = Initializer $ LT.getBase + + +------------------------------------------------------------------------------ +-- | 'modify' for InitializerState. +iModify :: (InitializerState b -> InitializerState b) -> Initializer b v () +iModify f = Initializer $ do + b <- LT.getBase + LT.putBase $ f b + + +------------------------------------------------------------------------------ +-- | 'gets' for InitializerState. +iGets :: (InitializerState b -> a) -> Initializer b v a +iGets f = Initializer $ do + b <- LT.getBase + return $ f b + + +------------------------------------------------------------------------------ +-- | Lets you retrieve the list of routes currently set up by an Initializer. +-- This can be useful in debugging. +getRoutes :: Initializer b v [ByteString] +getRoutes = liftM (map fst) $ iGets _handlers + +------------------------------------------------------------------------------ +-- | Return the current environment string. This will be the +-- environment given to 'runSnaplet' or from the command line when +-- using 'serveSnaplet'. Useful for changing behavior during +-- development and testing. +getEnvironment :: Initializer b v String +getEnvironment = iGets _environment + +------------------------------------------------------------------------------ +-- | Converts a plain hook into a Snaplet hook. +toSnapletHook :: (v -> IO (Either Text v)) + -> (Snaplet v -> IO (Either Text (Snaplet v))) +toSnapletHook f (Snaplet cfg reset val) = do + val' <- f val + return $! Snaplet cfg reset <$> val' + + +------------------------------------------------------------------------------ +-- | Adds an IO action that modifies the current snaplet state to be run at +-- the end of initialization on the state that was created. This makes it +-- easier to allow one snaplet's state to be modified by another snaplet's +-- initializer. A good example of this is when a snaplet has templates that +-- define its views. The Heist snaplet provides the 'addTemplates' function +-- which allows other snaplets to set up their own templates. 'addTemplates' +-- is implemented using this function. +addPostInitHook :: (v -> IO (Either Text v)) + -> Initializer b v () +addPostInitHook = addPostInitHook' . toSnapletHook + + +addPostInitHook' :: (Snaplet v -> IO (Either Text (Snaplet v))) + -> Initializer b v () +addPostInitHook' h = do + h' <- upHook h + addPostInitHookBase h' + + +------------------------------------------------------------------------------ +-- | Variant of addPostInitHook for when you have things wrapped in a Snaplet. +addPostInitHookBase :: (Snaplet b -> IO (Either Text (Snaplet b))) + -> Initializer b v () +addPostInitHookBase = Initializer . lift . tell . Hook + + +------------------------------------------------------------------------------ +-- | Helper function for transforming hooks. +upHook :: (Snaplet v -> IO (Either Text (Snaplet v))) + -> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b))) +upHook h = Initializer $ do + l <- ask + return $ upHook' l h + + +------------------------------------------------------------------------------ +-- | Helper function for transforming hooks. +upHook' :: Monad m => ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b) +upHook' l h b = do + v <- h (b ^# l) + return $ case v of + Left e -> Left e + Right v' -> Right $ storing l v' b + + +------------------------------------------------------------------------------ +-- | Modifies the Initializer's SnapletConfig. +modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v () +modifyCfg f = iModify $ over curConfig $ \c -> f c + + +------------------------------------------------------------------------------ +-- | If a snaplet has a filesystem presence, this function creates and copies +-- the files if they dont' already exist. +setupFilesystem :: Maybe (IO FilePath) + -- ^ The directory where the snaplet's reference files are + -- stored. Nothing if the snaplet doesn't come with any + -- files that need to be installed. + -> FilePath + -- ^ Directory where the files should be copied. + -> Initializer b v () +setupFilesystem Nothing _ = return () +setupFilesystem (Just getSnapletDataDir) targetDir = do + exists <- liftIO $ doesDirectoryExist targetDir + unless exists $ do + printInfo "...setting up filesystem" + liftIO $ createDirectoryIfMissing True targetDir + srcDir <- liftIO getSnapletDataDir + liftIO $ readDirectoryWith (doCopy srcDir targetDir) srcDir + return () + where + doCopy srcRoot targetRoot filename = do + createDirectoryIfMissing True directory + copyFile filename toDir + where + toDir = targetRoot makeRelative srcRoot filename + directory = dropFileName toDir + + +------------------------------------------------------------------------------ +-- | All snaplet initializers must be wrapped in a call to @makeSnaplet@, +-- which handles standardized housekeeping common to all snaplets. +-- Common usage will look something like +-- this: +-- +-- @ +-- fooInit :: SnapletInit b Foo +-- fooInit = makeSnaplet \"foo\" \"An example snaplet\" Nothing $ do +-- -- Your initializer code here +-- return $ Foo 42 +-- @ +-- +-- Note that you're writing your initializer code in the Initializer monad, +-- and makeSnaplet converts it into an opaque SnapletInit type. This allows +-- us to use the type system to ensure that the API is used correctly. +makeSnaplet :: Text + -- ^ A default id for this snaplet. This is only used when + -- the end-user has not already set an id using the + -- nameSnaplet function. + -> Text + -- ^ A human readable description of this snaplet. + -> Maybe (IO FilePath) + -- ^ The path to the directory holding the snaplet's reference + -- filesystem content. This will almost always be the + -- directory returned by Cabal's getDataDir command, but it + -- has to be passed in because it is defined in a + -- package-specific import. Setting this value to Nothing + -- doesn't preclude the snaplet from having files in in the + -- filesystem, it just means that they won't be copied there + -- automatically. + -> Initializer b v v + -- ^ Snaplet initializer. + -> SnapletInit b v +makeSnaplet snapletId desc getSnapletDataDir m = SnapletInit $ do + modifyCfg $ \c -> if isNothing $ _scId c + then set scId (Just snapletId) c else c + sid <- iGets (T.unpack . fromJust . _scId . _curConfig) + topLevel <- iGets _isTopLevel + unless topLevel $ do + modifyCfg $ over scUserConfig (subconfig (T.pack sid)) + modifyCfg $ \c -> set scFilePath + (_scFilePath c "snaplets" sid) c + iModify (set isTopLevel False) + modifyCfg $ set scDescription desc + cfg <- iGets _curConfig + printInfo $ T.pack $ concat + ["Initializing " + ,sid + ," @ /" + ,B.unpack $ buildPath $ _scRouteContext cfg + ] + + -- This has to happen here because it needs to be after scFilePath is set + -- up but before the config file is read. + setupFilesystem getSnapletDataDir (_scFilePath cfg) + + env <- iGets _environment + let configLocation = _scFilePath cfg (env ++ ".cfg") + liftIO $ addToConfig [Optional configLocation] + (_scUserConfig cfg) + mkSnaplet m + + +------------------------------------------------------------------------------ +-- | Internal function that gets the SnapletConfig out of the initializer +-- state and uses it to create a (Snaplet a). +mkSnaplet :: Initializer b v v -> Initializer b v (Snaplet v) +mkSnaplet m = do + res <- m + cfg <- iGets _curConfig + setInTop <- iGets masterReloader + l <- getLens + let modifier = setInTop . set (cloneLens l . snapletValue) + return $ Snaplet cfg modifier res + + + +------------------------------------------------------------------------------ +-- | Brackets an initializer computation, restoring curConfig after the +-- computation returns. +bracketInit :: Initializer b v a -> Initializer b v a +bracketInit m = do + s <- iGet + res <- m + iModify (set curConfig (_curConfig s)) + return res + + +------------------------------------------------------------------------------ +-- | Handles modifications to InitializerState that need to happen before a +-- snaplet is called with either nestSnaplet or embedSnaplet. +setupSnapletCall :: ByteString -> Initializer b v () +setupSnapletCall rte = do + curId <- iGets (fromJust . _scId . _curConfig) + modifyCfg (over scAncestry (curId:)) + modifyCfg (over scId (const Nothing)) + unless (B.null rte) $ modifyCfg (over scRouteContext (rte:)) + + +------------------------------------------------------------------------------ +-- | Runs another snaplet's initializer and returns the initialized Snaplet +-- value. Calling an initializer with nestSnaplet gives the nested snaplet +-- access to the same base state that the current snaplet has. This makes it +-- possible for the child snaplet to make use of functionality provided by +-- sibling snaplets. +nestSnaplet :: ByteString + -- ^ The root url for all the snaplet's routes. An empty + -- string gives the routes the same root as the parent + -- snaplet's routes. + -> SnapletLens v v1 + -- ^ Lens identifying the snaplet + -> SnapletInit b v1 + -- ^ The initializer function for the subsnaplet. + -> Initializer b v (Snaplet v1) +nestSnaplet rte l (SnapletInit snaplet) = + with l $ bracketInit $ do + setupSnapletCall rte + snaplet + + +------------------------------------------------------------------------------ +-- | Runs another snaplet's initializer and returns the initialized Snaplet +-- value. The difference between this and 'nestSnaplet' is the first type +-- parameter in the third argument. The \"v1 v1\" makes the child snaplet +-- think that it is the top-level state, which means that it will not be able +-- to use functionality provided by snaplets included above it in the snaplet +-- tree. This strongly isolates the child snaplet, and allows you to eliminate +-- the b type variable. The embedded snaplet can still get functionality +-- from other snaplets, but only if it nests or embeds the snaplet itself. +-- +-- Note that this function does not change where this snaplet is located in +-- the filesystem. The snaplet directory structure convention stays the same. +-- Also, embedSnaplet limits the ways that snaplets can interact, so we +-- usually recommend using nestSnaplet instead. However, we provide this +-- function because sometimes reduced flexibility is useful. In short, if +-- you don't understand what this function does for you from looking at its +-- type, you probably don't want to use it. +embedSnaplet :: ByteString + -- ^ The root url for all the snaplet's routes. An empty + -- string gives the routes the same root as the parent + -- snaplet's routes. + -- + -- NOTE: Because of the stronger isolation provided by + -- embedSnaplet, you should be more careful about using an + -- empty string here. + -> SnapletLens v v1 + -- ^ Lens identifying the snaplet + -> SnapletInit v1 v1 + -- ^ The initializer function for the subsnaplet. + -> Initializer b v (Snaplet v1) +embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do + curLens <- getLens + setupSnapletCall "" + chroot rte (cloneLens curLens . subSnaplet l) snaplet + + +------------------------------------------------------------------------------ +-- | Changes the base state of an initializer. +chroot :: ByteString + -> SnapletLens (Snaplet b) v1 + -> Initializer v1 v1 a + -> Initializer b v a +chroot rte l (Initializer m) = do + curState <- iGet + let newSetter f = masterReloader curState (over (cloneLens l) f) + ((a,s), (Hook hook)) <- liftIO $ runWriterT $ LT.runLensT m id $ + curState { + _handlers = [], + _hFilter = id, + masterReloader = newSetter + } + let handler = chrootHandler l $ _hFilter s $ route $ _handlers s + iModify $ over handlers (++[(rte,handler)]) + . set cleanup (_cleanup s) + addPostInitHookBase $ upHook' l hook + return a + + +------------------------------------------------------------------------------ +-- | Changes the base state of a handler. +chrootHandler :: SnapletLens (Snaplet v) b' + -> Handler b' b' a -> Handler b v a +chrootHandler l (Handler h) = Handler $ do + s <- get + (a, s') <- liftSnap $ L.runLensed h id (s ^# l) + modify $ storing l s' + return a + + +------------------------------------------------------------------------------ +-- | Sets a snaplet's name. All snaplets have a default name set by the +-- snaplet author. This function allows you to override that name. You will +-- have to do this if you have more than one instance of the same kind of +-- snaplet because snaplet names must be unique. This function must +-- immediately surround the snaplet's initializer. For example: +-- +-- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@ +nameSnaplet :: Text + -- ^ The snaplet name + -> SnapletInit b v + -- ^ The snaplet initializer function + -> SnapletInit b v +nameSnaplet nm (SnapletInit m) = SnapletInit $ + modifyCfg (set scId (Just nm)) >> m + + +------------------------------------------------------------------------------ +-- | Adds routing to the current 'Handler'. The new routes are merged with +-- the main routing section and take precedence over existing routing that was +-- previously defined. +addRoutes :: [(ByteString, Handler b v ())] + -> Initializer b v () +addRoutes rs = do + l <- getLens + ctx <- iGets (_scRouteContext . _curConfig) + let modRoute (r,h) = ( buildPath (r:ctx) + , setPattern r >> withTop' l h) + let rs' = map modRoute rs + iModify (\v -> over handlers (++rs') v) + where + setPattern r = do + p <- getRoutePattern + when (isNothing p) $ setRoutePattern r + + +------------------------------------------------------------------------------ +-- | Wraps the /base/ snaplet's routing in another handler, allowing you to run +-- code before and after all routes in an application. +-- +-- Here are some examples of things you might do: +-- +-- > wrapSite (\site -> logHandlerStart >> site >> logHandlerFinished) +-- > wrapSite (\site -> ensureAdminUser >> site) +-- +wrapSite :: (Handler b v () -> Handler b v ()) + -- ^ Handler modifier function + -> Initializer b v () +wrapSite f0 = do + f <- mungeFilter f0 + iModify (\v -> over hFilter (f.) v) + + +------------------------------------------------------------------------------ +mungeFilter :: (Handler b v () -> Handler b v ()) + -> Initializer b v (Handler b b () -> Handler b b ()) +mungeFilter f = do + myLens <- Initializer ask + return $ \m -> with' myLens $ f' m + where + f' (Handler m) = f $ Handler $ L.withTop id m + + +------------------------------------------------------------------------------ +-- | Attaches an unload handler to the snaplet. The unload handler will be +-- called when the server shuts down, or is reloaded. +onUnload :: IO () -> Initializer b v () +onUnload m = do + cleanupRef <- iGets _cleanup + liftIO $ atomicModifyIORef cleanupRef f + where + f curCleanup = (curCleanup >> m, ()) + + +------------------------------------------------------------------------------ +-- | +logInitMsg :: IORef Text -> Text -> IO () +logInitMsg ref msg = atomicModifyIORef ref (\cur -> (cur `T.append` msg, ())) + + +------------------------------------------------------------------------------ +-- | Initializers should use this function for all informational or error +-- messages to be displayed to the user. On application startup they will be +-- sent to the console. When executed from the reloader, they will be sent +-- back to the user in the HTTP response. +printInfo :: Text -> Initializer b v () +printInfo msg = do + logRef <- iGets _initMessages + liftIO $ logInitMsg logRef (msg `T.append` "\n") + + +------------------------------------------------------------------------------ +-- | Builds an IO reload action for storage in the SnapletState. +mkReloader :: FilePath + -> String + -> ((Snaplet b -> Snaplet b) -> IO ()) + -> IORef (IO ()) + -> Initializer b b (Snaplet b) + -> IO (Either Text Text) +mkReloader cwd env resetter cleanupRef i = do + join $ readIORef cleanupRef + !res <- runInitializer' resetter env i cwd + either (return . Left) good res + where + good (b,is) = do + _ <- resetter (const b) + msgs <- readIORef $ _initMessages is + return $ Right msgs + + +------------------------------------------------------------------------------ +-- | Runs a top-level snaplet in the Snap monad. +runBase :: Handler b b a + -> MVar (Snaplet b) + -> Snap a +runBase (Handler m) mvar = do + !b <- liftIO (readMVar mvar) + (!a, _) <- L.runLensed m id b + return $! a + + +------------------------------------------------------------------------------ +-- | Lets you change a snaplet's initial state. It's almost like a reload, +-- except that it doesn't run the initializer. It just modifies the result of +-- the initializer. This can be used to let you define actions for reloading +-- individual snaplets. +modifyMaster :: v -> Handler b v () +modifyMaster v = do + modifier <- getsSnapletState _snapletModifier + liftIO $ modifier v + + +------------------------------------------------------------------------------ +-- | Internal function for running Initializers. If any exceptions were +-- thrown by the initializer, this function catches them, runs any cleanup +-- actions that had been registered, and returns an expanded error message +-- containing the exception details as well as all messages generated by the +-- initializer before the exception was thrown. +runInitializer :: ((Snaplet b -> Snaplet b) -> IO ()) + -> String + -> Initializer b b (Snaplet b) + -> IO (Either Text (Snaplet b, InitializerState b)) +runInitializer resetter env b = + getCurrentDirectory >>= runInitializer' resetter env b + + +------------------------------------------------------------------------------ +runInitializer' :: ((Snaplet b -> Snaplet b) -> IO ()) + -> String + -> Initializer b b (Snaplet b) + -> FilePath + -> IO (Either Text (Snaplet b, InitializerState b)) +runInitializer' resetter env b@(Initializer i) cwd = do + cleanupRef <- newIORef (return ()) + let reloader_ = mkReloader cwd env resetter cleanupRef b + let builtinHandlers = [("/admin/reload", reloadSite)] + let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing reloader_ + logRef <- newIORef "" + + let body = do + ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $ + InitializerState True cleanupRef builtinHandlers id cfg logRef + env resetter + res' <- hook res + return $ (,s) <$> res' + + handler e = do + join $ readIORef cleanupRef + logMessages <- readIORef logRef + + return $ Left $ T.unlines + [ "Initializer threw an exception..." + , T.pack $ show (e :: SomeException) + , "" + , "...but before it died it generated the following output:" + , logMessages + ] + + catch body handler + + +------------------------------------------------------------------------------ +-- | Given an environment and a Snaplet initializer, produce a concatenated log +-- of all messages generated during initialization, a snap handler, and a +-- cleanup action. The environment is an arbitrary string such as \"devel\" or +-- \"production\". This string is used to determine the name of the +-- configuration files used by each snaplet. If an environment of Nothing is +-- used, then runSnaplet defaults to \"devel\". +runSnaplet :: Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ()) +runSnaplet env (SnapletInit b) = do + snapletMVar <- newEmptyMVar + let resetter f = modifyMVar_ snapletMVar (return . f) + eRes <- runInitializer resetter (fromMaybe "devel" env) b + let go (siteSnaplet,is) = do + putMVar snapletMVar siteSnaplet + msgs <- liftIO $ readIORef $ _initMessages is + let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar + cleanupAction <- readIORef $ _cleanup is + return (msgs, handler, cleanupAction) + either (error . ('\n':) . T.unpack) go eRes + + +------------------------------------------------------------------------------ +-- | Given a configuration and a snap handler, complete it and produce the +-- completed configuration as well as a new toplevel handler with things like +-- compression and a 500 handler set up. +combineConfig :: Config Snap a -> Snap () -> IO (Config Snap a, Snap ()) +combineConfig config handler = do + conf <- completeConfig config + + let catch500 = (flip catch $ fromJust $ getErrorHandler conf) + let compress = if fromJust (getCompression conf) + then withCompression else id + let site = compress $ catch500 handler + + return (conf, site) + + +------------------------------------------------------------------------------ +-- | Initialize and run a Snaplet. This function parses command-line arguments, +-- runs the given Snaplet initializer, and starts an HTTP server running the +-- Snaplet's toplevel 'Handler'. +serveSnaplet :: Config Snap AppConfig + -- ^ The configuration of the server - you can usually pass a + -- default 'Config' via + -- 'Snap.Http.Server.Config.defaultConfig'. + -> SnapletInit b b + -- ^ The snaplet initializer function. + -> IO () +serveSnaplet startConfig initializer = do + config <- commandLineAppConfig startConfig + serveSnapletNoArgParsing config initializer + +------------------------------------------------------------------------------ +-- | Like 'serveSnaplet', but don't try to parse command-line arguments. +serveSnapletNoArgParsing :: Config Snap AppConfig + -- ^ The configuration of the server - you can usually pass a + -- default 'Config' via + -- 'Snap.Http.Server.Config.defaultConfig'. + -> SnapletInit b b + -- ^ The snaplet initializer function. + -> IO () +serveSnapletNoArgParsing config initializer = do + let env = appEnvironment =<< getOther config + (msgs, handler, doCleanup) <- runSnaplet env initializer + + (conf, site) <- combineConfig config handler + createDirectoryIfMissing False "log" + let serve = httpServe conf + + when (loggingEnabled conf) $ liftIO $ hPutStrLn stderr $ T.unpack msgs + _ <- try $ serve $ site + :: IO (Either SomeException ()) + doCleanup + where + loggingEnabled = not . (== Just False) . getVerbose + + +------------------------------------------------------------------------------ +-- | Allows you to get all of your app's config data in the IO monad without +-- the web server infrastructure. +loadAppConfig :: FileName + -- ^ The name of the config file to look for. In snap + -- applications, this is something based on the + -- environment...i.e. @devel.cfg@. + -> FilePath + -- ^ Path to the root directory of your project. + -> IO C.Config +loadAppConfig cfg root = do + tree <- buildL root + let groups = loadAppConfig' cfg "" $ dirTree tree + loadGroups groups + + +------------------------------------------------------------------------------ +-- | Recursive worker for loadAppConfig. +loadAppConfig' :: FileName -> Text -> DirTree a -> [(Text, Worth a)] +loadAppConfig' cfg _prefix d@(Dir _ c) = + (map ((_prefix,) . Required) $ getCfg cfg d) ++ + concatMap (\a -> loadAppConfig' cfg (nextPrefix $ name a) a) snaplets + where + nextPrefix p = T.concat [_prefix, T.pack p, "."] + snapletsDirs = filter isSnapletsDir c + snaplets = concatMap (filter isDir . contents) snapletsDirs +loadAppConfig' _ _ _ = [] + + +isSnapletsDir :: DirTree t -> Bool +isSnapletsDir (Dir "snaplets" _) = True +isSnapletsDir _ = False + + +isDir :: DirTree t -> Bool +isDir (Dir _ _) = True +isDir _ = False + + +isCfg :: FileName -> DirTree t -> Bool +isCfg cfg (File n _) = cfg == n +isCfg _ _ = False + + +getCfg :: FileName -> DirTree b -> [b] +getCfg cfg (Dir _ c) = map file $ filter (isCfg cfg) c +getCfg _ _ = [] + + + diff --git a/src/Snap/Snaplet/Internal/LensT.hs b/src/Snap/Snaplet/Internal/LensT.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Internal/LensT.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Snap.Snaplet.Internal.LensT where + + +------------------------------------------------------------------------------ +import Control.Applicative (Alternative (..), + Applicative (..)) +import Control.Category ((.)) +import Control.Lens (ALens', cloneLens, storing, (^#)) +import Control.Monad (MonadPlus (..)) +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.State.Class (MonadState (..)) +import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), + MonadTransControl (..), + defaultLiftBaseWith, + defaultLiftWith, defaultRestoreM, + defaultRestoreT) +import Prelude (Functor (..), Monad (..), const, + ($), ($!)) +import Snap.Core (MonadSnap (..)) +import Snap.Snaplet.Internal.RST (RST (..), runRST, withRST) +------------------------------------------------------------------------------ + + +newtype LensT b v s m a = LensT (RST (ALens' b v) s m a) + deriving ( Monad + , MonadTrans + , Functor + , Applicative + , MonadIO + , MonadPlus + , Alternative + , MonadReader (ALens' b v)) + + +------------------------------------------------------------------------------ +instance Monad m => MonadState v (LensT b v b m) where + get = lGet + put = lPut + + +instance MonadBase bs m => MonadBase bs (LensT b v s m) where + liftBase = lift . liftBase + + +instance MonadBaseControl bs m => MonadBaseControl bs (LensT b v s m) where + type StM (LensT b v s m) a = ComposeSt (LensT b v s) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + + +instance MonadTransControl (LensT b v s) where + type StT (LensT b v s) a = StT (RST (ALens' b v) s) a + liftWith = defaultLiftWith LensT (\(LensT rst) -> rst) + restoreT = defaultRestoreT LensT + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} + + +instance MonadSnap m => MonadSnap (LensT b v s m) where + liftSnap m = LensT $ liftSnap m + + +------------------------------------------------------------------------------ +getBase :: Monad m => LensT b v s m s +getBase = LensT get +{-# INLINE getBase #-} + + +------------------------------------------------------------------------------ +putBase :: Monad m => s -> LensT b v s m () +putBase = LensT . put +{-# INLINE putBase #-} + + +------------------------------------------------------------------------------ +lGet :: Monad m => LensT b v b m v +lGet = LensT $ do + !l <- ask + !b <- get + return $! b ^# l +{-# INLINE lGet #-} + + +------------------------------------------------------------------------------ +lPut :: Monad m => v -> LensT b v b m () +lPut v = LensT $ do + !l <- ask + !b <- get + put $! storing l v b +{-# INLINE lPut #-} + + +------------------------------------------------------------------------------ +runLensT :: Monad m => LensT b v s m a -> ALens' b v -> s -> m (a, s) +runLensT (LensT m) l = runRST m l +{-# INLINE runLensT #-} + + +------------------------------------------------------------------------------ +withLensT :: Monad m + => (ALens' b' v' -> ALens' b v) + -> LensT b v s m a + -> LensT b' v' s m a +withLensT f (LensT m) = LensT $ withRST f m +{-# INLINE withLensT #-} + + +------------------------------------------------------------------------------ +withTop :: Monad m + => ALens' b v' + -> LensT b v' s m a + -> LensT b v s m a +withTop subLens = withLensT (const subLens) +{-# INLINE withTop #-} + + +------------------------------------------------------------------------------ +with :: Monad m => ALens' v v' -> LensT b v' s m a -> LensT b v s m a +with subLens = withLensT (\l -> cloneLens l . subLens) + diff --git a/src/Snap/Snaplet/Internal/Lensed.hs b/src/Snap/Snaplet/Internal/Lensed.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Internal/Lensed.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Snap.Snaplet.Internal.Lensed where + + +------------------------------------------------------------------------------ +import Control.Applicative (Alternative (..), + Applicative (..), (<$>)) +import Control.Category ((.)) +import Control.Lens (ALens', cloneLens, storing, (^#)) +import Control.Monad (MonadPlus (..), liftM) +import Control.Monad.Base (MonadBase (..)) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.State.Class (MonadState (..)) +import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), + MonadTransControl (..), + defaultLiftBaseWith, + defaultRestoreM) +import Control.Monad.Trans.State (StateT(..)) +import Prelude (Functor (..), Monad (..), ($)) +import Snap.Core (MonadSnap (..)) +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +newtype Lensed b v m a = Lensed + { unlensed :: ALens' b v -> v -> b -> m (a, v, b) } + + +------------------------------------------------------------------------------ +instance Functor m => Functor (Lensed b v m) where + fmap f (Lensed g) = Lensed $ \l v s -> + (\(a,v',s') -> (f a, v', s')) <$> g l v s + + +------------------------------------------------------------------------------ +instance (Functor m, Monad m) => Applicative (Lensed b v m) where + pure a = Lensed $ \_ v s -> return (a, v, s) + Lensed mf <*> Lensed ma = Lensed $ \l v s -> do + (f, v', s') <- mf l v s + (\(a,v'',s'') -> (f a, v'', s'')) <$> ma l v' s' + + +------------------------------------------------------------------------------ +instance Fail.MonadFail m => Fail.MonadFail (Lensed b v m) where + fail s = Lensed $ \_ _ _ -> Fail.fail s + + +------------------------------------------------------------------------------ +instance Monad m => Monad (Lensed b v m) where + return a = Lensed $ \_ v s -> return (a, v, s) + Lensed g >>= k = Lensed $ \l v s -> do + (a, v', s') <- g l v s + unlensed (k a) l v' s' + + +------------------------------------------------------------------------------ +instance Monad m => MonadState v (Lensed b v m) where + get = Lensed $ \_ v s -> return (v, v, s) + put v' = Lensed $ \_ _ s -> return ((), v', s) + + +instance Monad m => MonadReader (ALens' b v) (Lensed b v m) where + ask = Lensed $ \l v s -> return (l, v, s) + local = lensedLocal + +------------------------------------------------------------------------------ +lensedLocal :: Monad m => (ALens' b v -> ALens' b v') -> Lensed b v' m a -> Lensed b v m a +lensedLocal f g = do + l <- ask + withTop (f l) g + +------------------------------------------------------------------------------ +instance MonadTrans (Lensed b v) where + lift m = Lensed $ \_ v b -> do + res <- m + return (res, v, b) + +------------------------------------------------------------------------------ +instance MonadIO m => MonadIO (Lensed b v m) where + liftIO = lift . liftIO + + +------------------------------------------------------------------------------ +instance MonadPlus m => MonadPlus (Lensed b v m) where + mzero = lift mzero + m `mplus` n = Lensed $ \l v b -> + unlensed m l v b `mplus` unlensed n l v b + + +------------------------------------------------------------------------------ +instance (Monad m, Alternative m) => Alternative (Lensed b v m) where + empty = lift empty + Lensed m <|> Lensed n = Lensed $ \l v b -> m l v b <|> n l v b + + +------------------------------------------------------------------------------ +instance MonadSnap m => MonadSnap (Lensed b v m) where + liftSnap = lift . liftSnap + + +------------------------------------------------------------------------------ +instance MonadBase base m => MonadBase base (Lensed b v m) where + liftBase = lift . liftBase + + +------------------------------------------------------------------------------ +instance MonadBaseControl base m => MonadBaseControl base (Lensed b v m) where + type StM (Lensed b v m) a = ComposeSt (Lensed b v) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + + +------------------------------------------------------------------------------ +instance MonadTransControl (Lensed b v) where + type StT (Lensed b v) a = (a, v, b) + liftWith f = Lensed $ \l v b -> do + res <- f $ \(Lensed g) -> g l v b + return (res, v, b) + restoreT k = Lensed $ \_ _ _ -> k + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} + + +------------------------------------------------------------------------------ +globally :: Monad m => StateT b m a -> Lensed b v m a +globally (StateT f) = Lensed $ \l v s -> + liftM (\(a, s') -> (a, s' ^# l, s')) $ f (storing l v s) + + +------------------------------------------------------------------------------ +lensedAsState :: Monad m => Lensed b v m a -> ALens' b v -> StateT b m a +lensedAsState (Lensed f) l = StateT $ \s -> do + (a, v', s') <- f l (s ^# l) s + return (a, storing l v' s') + + +------------------------------------------------------------------------------ +getBase :: Monad m => Lensed b v m b +getBase = Lensed $ \_ v b -> return (b, v, b) + + +------------------------------------------------------------------------------ +withTop :: Monad m => ALens' b v' -> Lensed b v' m a -> Lensed b v m a +withTop l m = globally $ lensedAsState m l + + +------------------------------------------------------------------------------ +with :: Monad m => ALens' v v' -> Lensed b v' m a -> Lensed b v m a +with l g = do + l' <- ask + withTop (cloneLens l' . l) g + + +------------------------------------------------------------------------------ +embed :: Monad m => ALens' v v' -> Lensed v v' m a -> Lensed b v m a +embed l m = locally $ lensedAsState m l + + +------------------------------------------------------------------------------ +locally :: Monad m => StateT v m a -> Lensed b v m a +locally (StateT f) = Lensed $ \_ v s -> + liftM (\(a, v') -> (a, v', s)) $ f v + + +------------------------------------------------------------------------------ +runLensed :: Monad m + => Lensed t1 b m t + -> ALens' t1 b + -> t1 + -> m (t, t1) +runLensed (Lensed f) l s = do + (a, v', s') <- f l (s ^# l) s + return (a, storing l v' s') diff --git a/src/Snap/Snaplet/Internal/RST.hs b/src/Snap/Snaplet/Internal/RST.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Internal/RST.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Snap.Snaplet.Internal.RST where + +import Control.Applicative (Alternative (..), + Applicative (..)) +import Control.Monad +import Control.Monad.Base (MonadBase (..)) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.State.Class (MonadState (..)) +import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), + MonadTransControl (..), + defaultLiftBaseWith, + defaultRestoreM) +import Snap.Core (MonadSnap (..)) + + +------------------------------------------------------------------------------ +-- like RWST, but no writer to bog things down. Also assured strict, inlined +-- monad bind, etc +newtype RST r s m a = RST { runRST :: r -> s -> m (a, s) } + + +evalRST :: Monad m => RST r s m a -> r -> s -> m a +evalRST m r s = do + (a,_) <- runRST m r s + return a +{-# INLINE evalRST #-} + + +execRST :: Monad m => RST r s m a -> r -> s -> m s +execRST m r s = do + (_,!s') <- runRST m r s + return s' +{-# INLINE execRST #-} + + +withRST :: Monad m => (r' -> r) -> RST r s m a -> RST r' s m a +withRST f m = RST $ \r' s -> runRST m (f r') s +{-# INLINE withRST #-} + + +instance (Monad m) => MonadReader r (RST r s m) where + ask = RST $ \r s -> return (r,s) + local f m = RST $ \r s -> runRST m (f r) s + + +instance (Functor m) => Functor (RST r s m) where + fmap f m = RST $ \r s -> fmap (\(a,s') -> (f a, s')) $ runRST m r s + + +instance (Functor m, Monad m) => Applicative (RST r s m) where + pure = return + (<*>) = ap + + +instance (Functor m, MonadPlus m) => Alternative (RST r s m) where + empty = mzero + (<|>) = mplus + + +instance (Monad m) => MonadState s (RST r s m) where + get = RST $ \_ s -> return (s,s) + put x = RST $ \_ _ -> return ((),x) + + +mapRST :: (m (a, s) -> n (b, s)) -> RST r s m a -> RST r s n b +mapRST f m = RST $ \r s -> f (runRST m r s) + + +instance (MonadSnap m) => MonadSnap (RST r s m) where + liftSnap s = lift $ liftSnap s + +rwsBind :: Monad m => + RST r s m a + -> (a -> RST r s m b) + -> RST r s m b +rwsBind m f = RST go + where + go r !s = do + (a, !s') <- runRST m r s + runRST (f a) r s' +{-# INLINE rwsBind #-} + +instance (Monad m) => Monad (RST r s m) where + return a = RST $ \_ s -> return (a, s) + (>>=) = rwsBind +#if !MIN_VERSION_base(4,13,0) + fail msg = RST $ \_ _ -> fail msg +#endif + +instance Fail.MonadFail m => Fail.MonadFail (RST r s m) where + fail msg = RST $ \_ _ -> Fail.fail msg + +instance (MonadPlus m) => MonadPlus (RST r s m) where + mzero = RST $ \_ _ -> mzero + m `mplus` n = RST $ \r s -> runRST m r s `mplus` runRST n r s + + +instance (MonadIO m) => MonadIO (RST r s m) where + liftIO = lift . liftIO + + +instance MonadTrans (RST r s) where + lift m = RST $ \_ s -> do + a <- m + return $ s `seq` (a, s) + + +instance MonadBase b m => MonadBase b (RST r s m) where + liftBase = lift . liftBase + + +instance MonadBaseControl b m => MonadBaseControl b (RST r s m) where + type StM (RST r s m) a = ComposeSt (RST r s) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + + +instance MonadTransControl (RST r s) where + type StT (RST r s) a = (a, s) + liftWith f = RST $ \r s -> do + res <- f $ \(RST g) -> g r s + return (res, s) + restoreT k = RST $ \_ _ -> k + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} diff --git a/src/Snap/Snaplet/Internal/Types.hs b/src/Snap/Snaplet/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Internal/Types.hs @@ -0,0 +1,520 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +#ifndef MIN_VERSION_comonad +#define MIN_VERSION_comonad(x,y,z) 1 +#endif + +module Snap.Snaplet.Internal.Types where + +------------------------------------------------------------------------------ +import Control.Applicative (Alternative) +import Control.Lens (ALens', makeLenses, set) +import Control.Monad (MonadPlus, liftM) +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.Fail (MonadFail) +import Control.Monad.Reader (MonadIO (..), MonadReader (ask, local)) +import Control.Monad.State.Class (MonadState (get, put), gets) +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Writer (WriterT) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B (dropWhile, intercalate, null, reverse) +import Data.Configurator.Types (Config) +import Data.IORef (IORef) +import Data.Text (Text) +import Snap.Core (MonadSnap, Request (rqClientAddr), Snap, bracketSnap, getRequest, pass, writeText) +import qualified Snap.Snaplet.Internal.Lensed as L (Lensed (..), runLensed, with, withTop) +import qualified Snap.Snaplet.Internal.LensT as LT (LensT, getBase, with, withTop) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative) +import Data.Monoid (Monoid (mappend, mempty)) +#endif + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup(..)) +#endif + +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | An opaque data type holding internal snaplet configuration data. It is +-- exported publicly because the getOpaqueConfig function in MonadSnaplet +-- makes implementing new instances of MonadSnaplet more convenient. +data SnapletConfig = SnapletConfig + { _scAncestry :: [Text] + , _scFilePath :: FilePath + , _scId :: Maybe Text + , _scDescription :: Text + , _scUserConfig :: Config + , _scRouteContext :: [ByteString] + , _scRoutePattern :: Maybe ByteString + -- ^ Holds the actual route pattern passed to addRoutes for the + -- current handler. Nothing during initialization and before route + -- dispatech. + , _reloader :: IO (Either Text Text) -- might change + -- ^ This is the universal reload action for the top-level site. We + -- can't update this in place to be a reloader for each individual + -- snaplet because individual snaplets can't be reloaded in isolation + -- without losing effects that subsequent hooks may have had. + } + +makeLenses ''SnapletConfig + + +------------------------------------------------------------------------------ +-- | Joins a reversed list of directories into a path. +buildPath :: [ByteString] -> ByteString +buildPath ps = B.intercalate "/" $ filter (not . B.null) $ reverse ps + + +------------------------------------------------------------------------------ +-- | Joins a reversed list of directories into a path. +getRootURL :: SnapletConfig -> ByteString +getRootURL sc = buildPath $ _scRouteContext sc + + +------------------------------------------------------------------------------ +-- | Snaplet's type parameter 's' here is user-defined and can be any Haskell +-- type. A value of type @Snaplet s@ countains a couple of things: +-- +-- * a value of type @s@, called the \"user state\". +-- +-- * some bookkeeping data the framework uses to plug things together, like +-- the snaplet's configuration, the snaplet's root directory on the +-- filesystem, the snaplet's root URL, and so on. +data Snaplet s = Snaplet + { _snapletConfig :: SnapletConfig + , _snapletModifier :: s -> IO () + -- ^ See the _reloader comment for why we have to use this to reload + -- single snaplets in isolation. This action won't actually run the + -- initializer at all. It will only modify the existing state. It is + -- the responsibility of the snaplet author to avoid using this in + -- situations where it will destroy data in its state that was created + -- by subsequent hook actions. + , _snapletValue :: s + } + +makeLenses ''Snaplet + +--instance Functor Snaplet where +-- fmap f (Snaplet c r a) = Snaplet c r (f a) +-- +--instance Foldable Snaplet where +-- foldMap f (Snaplet _ _ a) = f a +-- +--instance Traversable Snaplet where +-- traverse f (Snaplet c r a) = Snaplet c r <$> f a +-- +--instance Comonad Snaplet where +-- extract (Snaplet _ _ a) = a +-- +-- #if !(MIN_VERSION_comonad(3,0,0)) +-- instance Extend Snaplet where +-- #endif +-- extend f w@(Snaplet c r _) = Snaplet c r (f w) + +{- +------------------------------------------------------------------------------ +-- | A lens referencing the opaque SnapletConfig data type held inside +-- Snaplet. +snapletConfig :: SimpleLens (Snaplet a) SnapletConfig + + +------------------------------------------------------------------------------ +-- | A lens referencing the user-defined state type wrapped by a Snaplet. +snapletValue :: SimpleLens (Snaplet a) a +-} + + +-- NOTE: We cannot use one of the smaller lens packages because none of them +-- include ALens'. We have to use ALens' because we use lenses inside f's... +-- f (Lens a b). That requires ImpredicativeTypes which doesn't work. We +-- also can't inline the type aliases because ALens' uses Pretext which is a +-- newtype and can't be supplied outside lens in a compatible way. + +------------------------------------------------------------------------------ +type SnapletLens s a = ALens' s (Snaplet a) + + +------------------------------------------------------------------------------ +-- | Transforms a lens of the type you get from makeLenses to an similar lens +-- that is more suitable for internal use. +subSnaplet :: SnapletLens a b + -> SnapletLens (Snaplet a) b +subSnaplet l = snapletValue . l + + +------------------------------------------------------------------------------ +-- | The m type parameter used in the MonadSnaplet type signatures will +-- usually be either Initializer or Handler, but other monads may sometimes be +-- useful. +-- +-- Minimal complete definition: +-- +-- * 'withTop'', 'with'', 'getLens', and 'getOpaqueConfig'. +-- +class MonadSnaplet m where + -- | Runs a child snaplet action in the current snaplet's context. If you + -- think about snaplet lenses using a filesystem path metaphor, the lens + -- supplied to this snaplet must be a relative path. In other words, the + -- lens's base state must be the same as the current snaplet. + with :: SnapletLens v v' + -- ^ A relative lens identifying a snaplet + -> m b v' a + -- ^ Action from the lense's snaplet + -> m b v a + with l = with' (subSnaplet l) + + -- | Like 'with' but doesn't impose the requirement that the action + -- being run be a descendant of the current snaplet. Using our filesystem + -- metaphor again, the lens for this function must be an absolute + -- path--it's base must be the same as the current base. + withTop :: SnapletLens b v' + -- ^ An \"absolute\" lens identifying a snaplet + -> m b v' a + -- ^ Action from the lense's snaplet + -> m b v a + withTop l = withTop' (subSnaplet l) + + -- | A variant of 'with' accepting a lens from snaplet to snaplet. Unlike + -- the lens used in the above 'with' function, this lens formulation has + -- an identity, which makes it useful in certain circumstances. The + -- lenses generated by 'makeLenses' will not work with this function, + -- however the lens returned by 'getLens' will. + -- + -- @with = with' . subSnaplet@ + with' :: SnapletLens (Snaplet v) v' + -> m b v' a -> m b v a + + -- Not providing a definition for this function in terms of withTop' + -- allows us to avoid extra Monad type class constraints, making the type + -- signature easier to read. + -- with' l m = flip withTop m . (l .) =<< getLens + + -- | The absolute version of 'with'' + withTop' :: SnapletLens (Snaplet b) v' + -> m b v' a -> m b v a + + -- | Gets the lens for the current snaplet. + getLens :: m b v (SnapletLens (Snaplet b) v) + + -- | Gets the current snaplet's opaque config data type. You'll only use + -- this function when writing MonadSnaplet instances. + getOpaqueConfig :: m b v SnapletConfig + -- NOTE: We can't just use a MonadState (Snaplet v) instance for this + -- because Initializer has SnapletConfig, but doesn't have a full Snaplet. + + +------------------------------------------------------------------------------ +-- | Gets a list of the names of snaplets that are direct ancestors of the +-- current snaplet. +getSnapletAncestry :: (Monad (m b v), MonadSnaplet m) => m b v [Text] +getSnapletAncestry = return . _scAncestry =<< getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Gets the snaplet's path on the filesystem. +getSnapletFilePath :: (Monad (m b v), MonadSnaplet m) => m b v FilePath +getSnapletFilePath = return . _scFilePath =<< getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Gets the current snaple's name. +getSnapletName :: (Monad (m b v), MonadSnaplet m) => m b v (Maybe Text) +getSnapletName = return . _scId =<< getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Gets a human readable description of the snaplet. +getSnapletDescription :: (Monad (m b v), MonadSnaplet m) => m b v Text +getSnapletDescription = return . _scDescription =<< getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Gets the config data structure for the current snaplet. +getSnapletUserConfig :: (Monad (m b v), MonadSnaplet m) => m b v Config +getSnapletUserConfig = return . _scUserConfig =<< getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Gets the base URL for the current snaplet. Directories get added to +-- the current snaplet path by calls to 'nestSnaplet'. +getSnapletRootURL :: (Monad (m b v), MonadSnaplet m) => m b v ByteString +getSnapletRootURL = liftM getRootURL getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Constructs a url relative to the current snaplet. +snapletURL :: (Monad (m b v), MonadSnaplet m) + => ByteString -> m b v ByteString +snapletURL suffix = do + cfg <- getOpaqueConfig + return $ buildPath (cleanSuffix : _scRouteContext cfg) + where + dropSlash = B.dropWhile (=='/') + cleanSuffix = B.reverse $ dropSlash $ B.reverse $ dropSlash suffix + + +------------------------------------------------------------------------------ +-- | Snaplet infrastructure is available during runtime request processing +-- through the Handler monad. There aren't very many standalone functions to +-- read about here, but this is deceptive. The key is in the type class +-- instances. Handler is an instance of 'MonadSnap', which means it is the +-- monad you will use to write all your application routes. It also has a +-- 'MonadSnaplet' instance, which gives you all the functionality described +-- above. +newtype Handler b v a = + Handler { _unHandler :: L.Lensed (Snaplet b) (Snaplet v) Snap a } + deriving ( Monad + , Functor + , Applicative + , MonadFail + , MonadIO + , MonadPlus + , Alternative + , MonadSnap) + + +------------------------------------------------------------------------------ +instance MonadBase IO (Handler b v) where + liftBase = liftIO + + +------------------------------------------------------------------------------ +newtype StMHandler b v a = StMHandler { + unStMHandler :: StM (L.Lensed (Snaplet b) (Snaplet v) Snap) a + } + + +instance MonadBaseControl IO (Handler b v) where + type StM (Handler b v) a = StMHandler b v a + liftBaseWith f = Handler + $ liftBaseWith + $ \g' -> f + $ \m -> liftM StMHandler + $ g' $ _unHandler m + restoreM = Handler . restoreM . unStMHandler + + +------------------------------------------------------------------------------ +-- | Gets the @Snaplet v@ from the current snaplet's state. +getSnapletState :: Handler b v (Snaplet v) +getSnapletState = Handler get + + +------------------------------------------------------------------------------ +-- | Puts a new @Snaplet v@ in the current snaplet's state. +putSnapletState :: Snaplet v -> Handler b v () +putSnapletState = Handler . put + + +------------------------------------------------------------------------------ +-- | Modifies the @Snaplet v@ in the current snaplet's state. +modifySnapletState :: (Snaplet v -> Snaplet v) -> Handler b v () +modifySnapletState f = do + s <- getSnapletState + putSnapletState (f s) + + +------------------------------------------------------------------------------ +-- | Gets the @Snaplet v@ from the current snaplet's state and applies a +-- function to it. +getsSnapletState :: (Snaplet v -> b) -> Handler b1 v b +getsSnapletState f = do + s <- getSnapletState + return (f s) + + +------------------------------------------------------------------------------ +-- | Lets you access the current snaplet's state through the 'MonadState' +-- interface. +instance MonadState v (Handler b v) where + get = getsSnapletState _snapletValue + put v = modifySnapletState (set snapletValue v) + + +------------------------------------------------------------------------------ +-- | Lets you access the current snaplet's state through the 'MonadReader' +-- interface. +instance MonadReader v (Handler b v) where + ask = getsSnapletState _snapletValue + local f m = do + cur <- ask + put (f cur) + res <- m + put cur + return res + + +------------------------------------------------------------------------------ +instance MonadSnaplet Handler where + getLens = Handler ask + with' !l (Handler !m) = Handler $ L.with l m + withTop' !l (Handler m) = Handler $ L.withTop l m + getOpaqueConfig = Handler $ gets _snapletConfig + + +------------------------------------------------------------------------------ +-- | Like 'runBase', but it doesn't require an MVar to be executed. +runPureBase :: Handler b b a -> Snaplet b -> Snap a +runPureBase (Handler m) b = do + (!a, _) <- L.runLensed m id b + return $! a + + +------------------------------------------------------------------------------ +-- | Gets the route pattern that matched for the handler. This lets you find +-- out exactly which of the strings you used in addRoutes matched. +getRoutePattern :: Handler b v (Maybe ByteString) +getRoutePattern = + withTop' id $ liftM _scRoutePattern getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Sets the route pattern that matched for the handler. Use this when to +-- override the default pattern which is the key to the alist passed to +-- addRoutes. +setRoutePattern :: ByteString -> Handler b v () +setRoutePattern p = withTop' id $ + modifySnapletState (set (snapletConfig . scRoutePattern) (Just p)) + + +------------------------------------------------------------------------------ +-- | Check whether the request comes from localhost. +isLocalhost :: MonadSnap m => m Bool +isLocalhost = do + rip <- liftM rqClientAddr getRequest + return $ elem rip [ "127.0.0.1" + , "localhost" + , "::1" ] + + +------------------------------------------------------------------------------ +-- | Pass if the request is not coming from localhost. +failIfNotLocal :: MonadSnap m => m b -> m b +failIfNotLocal m = do + isLocal <- isLocalhost + if isLocal then m else pass + + +------------------------------------------------------------------------------ +-- | Handler that reloads the site. +reloadSite :: Handler b v () +reloadSite = failIfNotLocal $ do + cfg <- getOpaqueConfig + !res <- liftIO $ _reloader cfg + either bad good res + where + bad msg = do + writeText $ "Error reloading site!\n\n" + writeText msg + good msg = do + writeText msg + writeText $ "Site successfully reloaded.\n" + + +------------------------------------------------------------------------------ +-- | This function brackets a Handler action in resource acquisition and +-- release. Like 'bracketSnap', this is provided because MonadCatchIO's +-- 'bracket' function doesn't work properly in the case of a short-circuit +-- return from the action being bracketed. +-- +-- In order to prevent confusion regarding the effects of the +-- aquisition and release actions on the Handler state, this function +-- doesn't accept Handler actions for the acquire or release actions. +-- +-- This function will run the release action in all cases where the +-- acquire action succeeded. This includes the following behaviors +-- from the bracketed Snap action. +-- +-- 1. Normal completion +-- +-- 2. Short-circuit completion, either from calling 'fail' or 'finishWith' +-- +-- 3. An exception being thrown. +bracketHandler :: IO a -> (a -> IO x) -> (a -> Handler b v c) -> Handler b v c +bracketHandler begin end f = Handler . L.Lensed $ \l v b -> do + bracketSnap begin end $ \a -> case f a of Handler m -> L.unlensed m l v b + + +------------------------------------------------------------------------------ +-- | Information about a partially constructed initializer. Used to +-- automatically aggregate handlers and cleanup actions. +data InitializerState b = InitializerState + { _isTopLevel :: Bool + , _cleanup :: IORef (IO ()) + , _handlers :: [(ByteString, Handler b b ())] + -- ^ Handler routes built up and passed to route. + , _hFilter :: Handler b b () -> Handler b b () + -- ^ Generic filtering of handlers + , _curConfig :: SnapletConfig + -- ^ This snaplet config is the incrementally built config for + -- whatever snaplet is currently being constructed. + , _initMessages :: IORef Text + , _environment :: String + , masterReloader :: (Snaplet b -> Snaplet b) -> IO () + -- ^ We can't just hae a simple MVar here because MVars can't be + -- chrooted. + } + + +------------------------------------------------------------------------------ +-- | Wrapper around IO actions that modify state elements created during +-- initialization. +newtype Hook a = Hook (Snaplet a -> IO (Either Text (Snaplet a))) + +instance Semigroup (Hook a) where + Hook a <> Hook b = Hook $ \s -> do + ea <- a s + case ea of + Left e -> return $ Left e + Right ares -> do + eb <- b ares + case eb of + Left e -> return $ Left e + Right bres -> return $ Right bres + + +------------------------------------------------------------------------------ +instance Monoid (Hook a) where + mempty = Hook (return . Right) +#if !MIN_VERSION_base(4,11,0) + mappend = (<>) +#endif + + +------------------------------------------------------------------------------ +-- | Monad used for initializing snaplets. +newtype Initializer b v a = + Initializer (LT.LensT (Snaplet b) + (Snaplet v) + (InitializerState b) + (WriterT (Hook b) IO) + a) + deriving (Applicative, Functor, Monad, MonadIO) + +makeLenses ''InitializerState + + +------------------------------------------------------------------------------ +instance MonadSnaplet Initializer where + getLens = Initializer ask + with' !l (Initializer !m) = Initializer $ LT.with l m + withTop' !l (Initializer m) = Initializer $ LT.withTop l m + getOpaqueConfig = Initializer $ liftM _curConfig LT.getBase + + +------------------------------------------------------------------------------ +-- | Opaque newtype which gives us compile-time guarantees that the user is +-- using makeSnaplet and either nestSnaplet or embedSnaplet correctly. +newtype SnapletInit b v = SnapletInit (Initializer b v (Snaplet v)) diff --git a/src/Snap/Snaplet/Session.hs b/src/Snap/Snaplet/Session.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session.hs @@ -0,0 +1,129 @@ +module Snap.Snaplet.Session + ( SessionManager + , withSession + , commitSession + , setInSession + , getFromSession + , deleteFromSession + , csrfToken + , sessionToList + , resetSession + , touchSession + + -- * Utilities Exported For Convenience + , module Snap.Snaplet.Session.Common + , module Snap.Snaplet.Session.SecureCookie + ) where + +------------------------------------------------------------------------------ +import Control.Monad.State +import Data.Text (Text) +import Snap.Core +------------------------------------------------------------------------------ +import Snap.Snaplet +import Snap.Snaplet.Session.Common +import Snap.Snaplet.Session.SecureCookie +import Snap.Snaplet.Session.SessionManager + ( ISessionManager(..), SessionManager(..) ) +import qualified Snap.Snaplet.Session.SessionManager as SM +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | Wrap around a handler, committing any changes in the session at the end +-- +withSession :: SnapletLens b SessionManager + -> Handler b v a + -> Handler b v a +withSession l h = do + a <- h + withTop l commitSession + return a + + +------------------------------------------------------------------------------ +-- | Commit changes to session within the current request cycle +-- +commitSession :: Handler b SessionManager () +commitSession = do + SessionManager b <- loadSession + liftSnap $ commit b + + +------------------------------------------------------------------------------ +-- | Set a key-value pair in the current session +-- +setInSession :: Text -> Text -> Handler b SessionManager () +setInSession k v = do + SessionManager r <- loadSession + let r' = SM.insert k v r + put $ SessionManager r' + + +------------------------------------------------------------------------------ +-- | Get a key from the current session +-- +getFromSession :: Text -> Handler b SessionManager (Maybe Text) +getFromSession k = do + SessionManager r <- loadSession + return $ SM.lookup k r + + +------------------------------------------------------------------------------ +-- | Remove a key from the current session +-- +deleteFromSession :: Text -> Handler b SessionManager () +deleteFromSession k = do + SessionManager r <- loadSession + let r' = SM.delete k r + put $ SessionManager r' + + +------------------------------------------------------------------------------ +-- | Returns a CSRF Token unique to the current session +-- +csrfToken :: Handler b SessionManager Text +csrfToken = do + mgr@(SessionManager r) <- loadSession + put mgr + return $ SM.csrf r + + +------------------------------------------------------------------------------ +-- | Return session contents as an association list +-- +sessionToList :: Handler b SessionManager [(Text, Text)] +sessionToList = do + SessionManager r <- loadSession + return $ SM.toList r + + +------------------------------------------------------------------------------ +-- | Deletes the session cookie, effectively resetting the session +-- +resetSession :: Handler b SessionManager () +resetSession = do + SessionManager r <- loadSession + r' <- liftSnap $ SM.reset r + put $ SessionManager r' + + +------------------------------------------------------------------------------ +-- | Touch the session so the timeout gets refreshed +-- +touchSession :: Handler b SessionManager () +touchSession = do + SessionManager r <- loadSession + let r' = SM.touch r + put $ SessionManager r' + + +------------------------------------------------------------------------------ +-- | Load the session into the manager +-- +loadSession :: Handler b SessionManager SessionManager +loadSession = do + SessionManager r <- get + r' <- liftSnap $ load r + return $ SessionManager r' + diff --git a/src/Snap/Snaplet/Session/Backends/CookieSession.hs b/src/Snap/Snaplet/Session/Backends/CookieSession.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/Backends/CookieSession.hs @@ -0,0 +1,205 @@ +------------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Snap.Snaplet.Session.Backends.CookieSession + ( initCookieSessionManager + ) where + +------------------------------------------------------------------------------ +import Control.Monad.Reader +import Data.ByteString (ByteString) +import Data.Typeable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Serialize (Serialize) +import qualified Data.Serialize as S +import Data.Text (Text) +import Data.Text.Encoding +import Snap.Core (Snap) +import Web.ClientSession + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +------------------------------------------------------------------------------ +import Snap.Snaplet +import Snap.Snaplet.Session +import Snap.Snaplet.Session.SessionManager +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------ +-- | Session data are kept in a 'HashMap' for this backend +-- +type Session = HashMap Text Text + + +------------------------------------------------------------------------------ +-- | This is what the 'Payload' will be for the CookieSession backend +-- +data CookieSession = CookieSession + { csCSRFToken :: Text + , csSession :: Session + } + deriving (Eq, Show) + + +------------------------------------------------------------------------------ +instance Serialize CookieSession where + put (CookieSession a b) = + S.put (encodeUtf8 a, map encodeTuple $ HM.toList b) + get = + let unpack (a,b) = CookieSession (decodeUtf8 a) + (HM.fromList $ map decodeTuple b) + in unpack <$> S.get + + +encodeTuple :: (Text, Text) -> (ByteString, ByteString) +encodeTuple (a,b) = (encodeUtf8 a, encodeUtf8 b) + + +decodeTuple :: (ByteString, ByteString) -> (Text, Text) +decodeTuple (a,b) = (decodeUtf8 a, decodeUtf8 b) + + +------------------------------------------------------------------------------ +mkCookieSession :: RNG -> IO CookieSession +mkCookieSession rng = do + t <- liftIO $ mkCSRFToken rng + return $ CookieSession t HM.empty + + +------------------------------------------------------------------------------ +-- | The manager data type to be stuffed into 'SessionManager' +-- +data CookieSessionManager = CookieSessionManager { + session :: Maybe CookieSession + -- ^ Per request cache for 'CookieSession' + , siteKey :: Key + -- ^ A long encryption key used for secure cookie transport + , cookieName :: ByteString + -- ^ Cookie name for the session system + , cookieDomain :: Maybe ByteString + -- ^ Cookie domain for session system. You may want to set it to + -- dot prefixed domain name like ".example.com", so the cookie is + -- available to sub domains. + , timeOut :: Maybe Int + -- ^ Session cookies will be considered "stale" after this many + -- seconds. + , randomNumberGenerator :: RNG + -- ^ handle to a random number generator +} deriving (Typeable) + + +------------------------------------------------------------------------------ +loadDefSession :: CookieSessionManager -> IO CookieSessionManager +loadDefSession mgr@(CookieSessionManager ses _ _ _ _ rng) = + case ses of + Nothing -> do ses' <- mkCookieSession rng + return $! mgr { session = Just ses' } + Just _ -> return mgr + + +------------------------------------------------------------------------------ +modSession :: (Session -> Session) -> CookieSession -> CookieSession +modSession f (CookieSession t ses) = CookieSession t (f ses) + + +------------------------------------------------------------------------------ +-- | Initialize a cookie-backed session, returning a 'SessionManager' to be +-- stuffed inside your application's state. This 'SessionManager' will enable +-- the use of all session storage functionality defined in +-- 'Snap.Snaplet.Session' +-- +initCookieSessionManager + :: FilePath -- ^ Path to site-wide encryption key + -> ByteString -- ^ Session cookie name + -> Maybe ByteString -- ^ Session cookie domain + -> Maybe Int -- ^ Session time-out (replay attack protection) + -> SnapletInit b SessionManager +initCookieSessionManager fp cn dom to = + makeSnaplet "CookieSession" + "A snaplet providing sessions via HTTP cookies." + Nothing $ liftIO $ do + key <- getKey fp + rng <- liftIO mkRNG + return $! SessionManager $ CookieSessionManager Nothing key cn dom to rng + + +------------------------------------------------------------------------------ +instance ISessionManager CookieSessionManager where + + -------------------------------------------------------------------------- + load mgr@(CookieSessionManager r _ _ _ _ _) = + case r of + Just _ -> return mgr + Nothing -> do + pl <- getPayload mgr + case pl of + Nothing -> liftIO $ loadDefSession mgr + Just (Payload x) -> do + let c = S.decode x + case c of + Left _ -> liftIO $ loadDefSession mgr + Right cs -> return $ mgr { session = Just cs } + + -------------------------------------------------------------------------- + commit mgr@(CookieSessionManager r _ _ _ _ rng) = do + pl <- case r of + Just r' -> return . Payload $ S.encode r' + Nothing -> liftIO (mkCookieSession rng) >>= + return . Payload . S.encode + setPayload mgr pl + + -------------------------------------------------------------------------- + reset mgr = do + cs <- liftIO $ mkCookieSession (randomNumberGenerator mgr) + return $ mgr { session = Just cs } + + -------------------------------------------------------------------------- + touch = id + + -------------------------------------------------------------------------- + insert k v mgr@(CookieSessionManager r _ _ _ _ _) = case r of + Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' } + Nothing -> mgr + + -------------------------------------------------------------------------- + lookup k (CookieSessionManager r _ _ _ _ _) = r >>= HM.lookup k . csSession + + -------------------------------------------------------------------------- + delete k mgr@(CookieSessionManager r _ _ _ _ _) = case r of + Just r' -> mgr { session = Just $ modSession (HM.delete k) r' } + Nothing -> mgr + + -------------------------------------------------------------------------- + csrf (CookieSessionManager r _ _ _ _ _) = case r of + Just r' -> csCSRFToken r' + Nothing -> "" + + -------------------------------------------------------------------------- + toList (CookieSessionManager r _ _ _ _ _) = case r of + Just r' -> HM.toList . csSession $ r' + Nothing -> [] + + +------------------------------------------------------------------------------ +-- | A session payload to be stored in a SecureCookie. +newtype Payload = Payload ByteString + deriving (Eq, Show, Ord, Serialize) + + +------------------------------------------------------------------------------ +-- | Get the current client-side value +getPayload :: CookieSessionManager -> Snap (Maybe Payload) +getPayload mgr = getSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr) + + +------------------------------------------------------------------------------ +-- | Set the client-side value +setPayload :: CookieSessionManager -> Payload -> Snap () +setPayload mgr x = setSecureCookie (cookieName mgr) (cookieDomain mgr) + (siteKey mgr) (timeOut mgr) x diff --git a/src/Snap/Snaplet/Session/Common.hs b/src/Snap/Snaplet/Session/Common.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/Common.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +------------------------------------------------------------------------------ +-- | This module contains functionality common among multiple back-ends. +-- + +module Snap.Snaplet.Session.Common + ( RNG + , mkRNG + , withRNG + , randomToken + , mkCSRFToken + ) where + +------------------------------------------------------------------------------ +import Control.Concurrent +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.Text.Encoding as T +import Data.Text (Text) +import Numeric +import System.Random.MWC + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + + +------------------------------------------------------------------------------ +-- | High speed, mutable random number generator state +newtype RNG = RNG (MVar GenIO) + +------------------------------------------------------------------------------ +-- | Perform given action, mutating the RNG state +withRNG :: RNG + -> (GenIO -> IO a) + -> IO a +withRNG (RNG rng) m = withMVar rng m + + +------------------------------------------------------------------------------ +-- | Create a new RNG +mkRNG :: IO RNG +mkRNG = withSystemRandom (newMVar >=> return . RNG) + + +------------------------------------------------------------------------------ +-- | Generates a random salt of given length +randomToken :: Int -> RNG -> IO ByteString +randomToken n rng = do + is <- withRNG rng $ \gen -> sequence . take n . repeat $ mk gen + return . B.pack . concat . map (flip showHex "") $ is + where + mk :: GenIO -> IO Int + mk = uniformR (0,15) + + +------------------------------------------------------------------------------ +-- | Generate a randomized CSRF token +mkCSRFToken :: RNG -> IO Text +mkCSRFToken rng = T.decodeUtf8 <$> randomToken 40 rng diff --git a/src/Snap/Snaplet/Session/SecureCookie.hs b/src/Snap/Snaplet/Session/SecureCookie.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/SecureCookie.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------------------------ +-- | This is a support module meant to back all session back-end +-- implementations. +-- +-- It gives us an encrypted and timestamped cookie that can store an arbitrary +-- serializable payload. For security, it will: +-- +-- * Encrypt its payload together with a timestamp. +-- +-- * Check the timestamp for session expiration everytime you read from the +-- cookie. This will limit intercept-and-replay attacks by disallowing +-- cookies older than the timeout threshold. + +module Snap.Snaplet.Session.SecureCookie + ( SecureCookie + , getSecureCookie + , setSecureCookie + , expireSecureCookie + -- ** Helper functions + , encodeSecureCookie + , decodeSecureCookie + , checkTimeout + ) where + +------------------------------------------------------------------------------ +import Control.Monad +import Control.Monad.Trans +import Data.ByteString (ByteString) +import Data.Serialize +import Data.Time +import Data.Time.Clock.POSIX +import Snap.Core +import Web.ClientSession + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +------------------------------------------------------------------------------ +-- | Arbitrary payload with timestamp. +type SecureCookie t = (UTCTime, t) + + +------------------------------------------------------------------------------ +-- | Get the cookie payload. +getSecureCookie :: (MonadSnap m, Serialize t) + => ByteString -- ^ Cookie name + -> Key -- ^ Encryption key + -> Maybe Int -- ^ Timeout in seconds + -> m (Maybe t) +getSecureCookie name key timeout = do + rqCookie <- getCookie name + rspCookie <- getResponseCookie name <$> getResponse + let ck = rspCookie `mplus` rqCookie + let val = fmap cookieValue ck >>= decodeSecureCookie key + case val of + Nothing -> return Nothing + Just (ts, t) -> do + to <- checkTimeout timeout ts + return $ case to of + True -> Nothing + False -> Just t + + +------------------------------------------------------------------------------ +-- | Decode secure cookie payload wih key. +decodeSecureCookie :: Serialize a + => Key -- ^ Encryption key + -> ByteString -- ^ Encrypted payload + -> Maybe (SecureCookie a) +decodeSecureCookie key value = do + cv <- decrypt key value + (i, val) <- either (const Nothing) Just $ decode cv + return $ (posixSecondsToUTCTime (fromInteger i), val) + + +------------------------------------------------------------------------------ +-- | Inject the payload. +setSecureCookie :: (MonadSnap m, Serialize t) + => ByteString -- ^ Cookie name + -> Maybe ByteString -- ^ Cookie domain + -> Key -- ^ Encryption key + -> Maybe Int -- ^ Max age in seconds + -> t -- ^ Serializable payload + -> m () +setSecureCookie name domain key to val = do + t <- liftIO getCurrentTime + val' <- encodeSecureCookie key (t, val) + let expire = to >>= Just . flip addUTCTime t . fromIntegral + let nc = Cookie name val' expire domain (Just "/") False True + modifyResponse $ addResponseCookie nc + + +------------------------------------------------------------------------------ +-- | Encode SecureCookie with key into injectable payload +encodeSecureCookie :: (MonadIO m, Serialize t) + => Key -- ^ Encryption key + -> SecureCookie t -- ^ Payload + -> m ByteString +encodeSecureCookie key (t, val) = + liftIO $ encryptIO key . encode $ (seconds, val) + where + seconds = round (utcTimeToPOSIXSeconds t) :: Integer + + +------------------------------------------------------------------------------ +-- | Expire secure cookie +expireSecureCookie :: MonadSnap m + => ByteString -- ^ Cookie name + -> Maybe ByteString -- ^ Cookie domain + -> m () +expireSecureCookie name domain = expireCookie cookie + where + cookie = Cookie name "" Nothing domain (Just "/") False False + + +------------------------------------------------------------------------------ +-- | Validate session against timeout policy. +-- +-- * If timeout is set to 'Nothing', never trigger a time-out. +-- +-- * Otherwise, do a regular time-out check based on current time and given +-- timestamp. +checkTimeout :: (MonadSnap m) => Maybe Int -> UTCTime -> m Bool +checkTimeout Nothing _ = return False +checkTimeout (Just x) t0 = do + t1 <- liftIO getCurrentTime + return $ t1 > addUTCTime (fromIntegral x) t0 diff --git a/src/Snap/Snaplet/Session/SessionManager.hs b/src/Snap/Snaplet/Session/SessionManager.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/SessionManager.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ExistentialQuantification #-} + +{-| This module is meant to be used mainly by Session backend +developers, who would naturally need access to ISessionManager class +internals. You can also use it if you need low-level access to the +backend functionality.-} + +module Snap.Snaplet.Session.SessionManager where + +------------------------------------------------------------------------------- +import Data.Text (Text) +import Prelude hiding (lookup) +------------------------------------------------------------------------------- +import Snap.Core (Snap) +------------------------------------------------------------------------------- + + + +-- | Any Haskell record that is a member of the 'ISessionManager' +-- typeclass can be stuffed inside a 'SessionManager' to enable all +-- session-related functionality. +-- +-- To use sessions in your application, just find a Backend that would +-- produce one for you inside of your 'Initializer'. See +-- 'initCookieSessionManager' in +-- 'Snap.Snaplet.Session.Backends.CookieSession' for a built-in option +-- that would get you started. +data SessionManager = forall a. ISessionManager a => SessionManager a + + +class ISessionManager r where + + -- | Load a session from given payload. + -- + -- Will always be called before any other operation. If possible, cache and + -- do nothing when called multiple times within the same request cycle. + load :: r -> Snap r + + -- | Commit session, return a possibly updated paylaod + commit :: r -> Snap () + + -- | Reset session + reset :: r -> Snap r + + -- | Touch session + touch :: r -> r + + -- | Insert a key-value pair into session + insert :: Text -> Text -> r -> r + + -- | Lookup a key in session + lookup :: Text -> r -> (Maybe Text) + + -- | Delete a key in session + delete :: Text -> r -> r + + -- | Return a session-specific CSRF protection token. See 'mkCSRFToken' for + -- help in creating the value. + csrf :: r -> Text + + -- | Return all key-value pairs as an association list + toList :: r -> [(Text,Text)] + diff --git a/src/Snap/Snaplet/Test.hs b/src/Snap/Snaplet/Test.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Test.hs @@ -0,0 +1,170 @@ +-- | The Snap.Snaplet.Test module contains primitives and combinators for +-- testing Snaplets. +module Snap.Snaplet.Test + ( + -- ** Testing handlers + evalHandler + , evalHandler' + , runHandler + , runHandler' + , getSnaplet + , closeSnaplet + , InitializerState + , withTemporaryFile + ) + where + + +------------------------------------------------------------------------------ +import Control.Concurrent.MVar +import Control.Exception.Base (finally) +import qualified Control.Exception as E +import Control.Monad.IO.Class +import Control.Monad (join) +import Data.Maybe (fromMaybe) +import Data.IORef +import Data.Text +import System.Directory +import System.IO.Error + + +------------------------------------------------------------------------------ +import Snap.Core +import Snap.Snaplet +import Snap.Snaplet.Internal.Types +import Snap.Test hiding (evalHandler, runHandler) +import qualified Snap.Test as ST +import Snap.Snaplet.Internal.Initializer + + +------------------------------------------------------------------------------ +-- | Remove the given file after running an IO computation. Obviously it +-- can be used with 'Assertion'. +withTemporaryFile :: FilePath -> IO () -> IO () +withTemporaryFile f = finally (removeFileMayNotExist f) + + +------------------------------------------------------------------------------ +-- | Utility function taken from Darcs +removeFileMayNotExist :: FilePath -> IO () +removeFileMayNotExist f = catchNonExistence (removeFile f) () + where + catchNonExistence :: IO a -> a -> IO a + catchNonExistence job nonexistval = + E.catch job $ + \e -> if isDoesNotExistError e then return nonexistval + else ioError e + + +------------------------------------------------------------------------------ +-- | Helper to keep "runHandler" and "evalHandler" DRY. +execHandlerComputation :: MonadIO m + => (RequestBuilder m () -> Snap v -> m a) + -> Maybe String + -> RequestBuilder m () + -> Handler b b v + -> SnapletInit b b + -> m (Either Text a) +execHandlerComputation f env rq h s = do + app <- getSnaplet env s + case app of + (Left e) -> return $ Left e + (Right (a, is)) -> execHandlerSnaplet a is f rq h + + +------------------------------------------------------------------------------ +-- | Helper to allow multiple calls to "runHandler" or "evalHandler" without +-- multiple initializations. +execHandlerSnaplet :: MonadIO m + => Snaplet b + -> InitializerState b + -> (RequestBuilder m () -> Snap v -> m a) + -> RequestBuilder m () + -> Handler b b v + -> m (Either Text a) +execHandlerSnaplet a is f rq h = do + res <- f rq $ runPureBase h a + closeSnaplet is + return $ Right res + +------------------------------------------------------------------------------ +-- | Given a Snaplet Handler and a 'RequestBuilder' defining +-- a test request, runs the Handler, producing an HTTP 'Response'. +-- +-- Note that the output of this function is slightly different from +-- 'runHandler' defined in Snap.Test, because due to the fact running +-- the initializer inside 'SnapletInit' can throw an exception. +runHandler :: MonadIO m + => Maybe String + -> RequestBuilder m () + -> Handler b b v + -> SnapletInit b b + -> m (Either Text Response) +runHandler = execHandlerComputation ST.runHandler + +------------------------------------------------------------------------------ +-- | A variant of runHandler that takes the Snaplet and InitializerState as +-- produced by getSnaplet, so those can be re-used across requests. It does not +-- run cleanup actions, so closeSnaplet should be used when finished. +runHandler' :: MonadIO m + => Snaplet b + -> InitializerState b + -> RequestBuilder m () + -> Handler b b v + -> m (Either Text Response) +runHandler' a is = execHandlerSnaplet a is ST.runHandler + + +------------------------------------------------------------------------------ +-- | Given a Snaplet Handler, a 'SnapletInit' specifying the initial state, +-- and a 'RequestBuilder' defining a test request, runs the handler, +-- returning the monadic value it produces. +-- +-- Throws an exception if the 'Snap' handler early-terminates with 'finishWith' +-- or 'mzero'. +-- +-- Note that the output of this function is slightly different from +-- 'evalHandler defined in Snap.Test, because due to the fact running +-- the initializer inside 'SnapletInit' can throw an exception. +evalHandler :: MonadIO m + => Maybe String + -> RequestBuilder m () + -> Handler b b a + -> SnapletInit b b + -> m (Either Text a) +evalHandler = execHandlerComputation ST.evalHandler + + +------------------------------------------------------------------------------ +-- | A variant of evalHandler that takes the Snaplet and InitializerState as +-- produced by getSnaplet, so those can be re-used across requests. It does not +-- run cleanup actions, so closeSnaplet should be used when finished. +evalHandler' :: MonadIO m + => Snaplet b + -> InitializerState b + -> RequestBuilder m () + -> Handler b b a + -> m (Either Text a) +evalHandler' a is = execHandlerSnaplet a is ST.evalHandler + +------------------------------------------------------------------------------ +-- | Run the given initializer, yielding a tuple where the first element is +-- a @Snaplet b@, or an error message whether the initializer threw an +-- exception. This is only needed for runHandler'/evalHandler'. +getSnaplet :: MonadIO m + => Maybe String + -> SnapletInit b b + -> m (Either Text (Snaplet b, InitializerState b)) +getSnaplet env (SnapletInit initializer) = liftIO $ do + mvar <- newEmptyMVar + let resetter f = modifyMVar_ mvar (return . f) + runInitializer resetter (fromMaybe "devel" env) initializer + +------------------------------------------------------------------------------ +-- | Run cleanup for an initializer. Should be run after finished using the +-- state that getSnaplet returned. Only needed if using getSnaplet and +-- evalHandler'/runHandler'. +closeSnaplet :: MonadIO m + => InitializerState b + -> m () +closeSnaplet is = liftIO $ join (readIORef $ _cleanup is) diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs deleted file mode 100644 --- a/src/Snap/Starter.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - ------------------------------------------------------------------------------- -import Char -import Data.List -import qualified Data.ByteString.Char8 as S -import qualified Data.Text as T -import Snap.Http.Server (snapServerVersion) -import System -import System.Directory -import System.Console.GetOpt -import System.FilePath ------------------------------------------------------------------------------- - -import Snap.StarterTH - - ------------------------------------------------------------------------------- --- Creates a value tDir :: ([String], [(String, String)]) -$(buildData "tDirBareBones" "barebones") -$(buildData "tDirDefault" "default") - ------------------------------------------------------------------------------- -usage :: String -usage = unlines - [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter" - , "" - , "Usage:" - , "" - , " snap " - , "" - , " can be one of:" - , " init - create a new project directory structure in the " ++ - "current directory" - , "" - , " Note: you can use --help after any of the above actions to get help " - , " on that action" - ] - - ------------------------------------------------------------------------------- -data InitFlag = InitBareBones - | InitHelp - | InitExtensions - deriving (Show, Eq) - - -setup :: String -> ([FilePath], [(String, String)]) -> IO () -setup projName tDir = do - mapM createDirectory (fst tDir) - mapM_ write (snd tDir) - where - write (f,c) = - if isSuffixOf "foo.cabal" f - then writeFile (projName ++ ".cabal") (insertProjName $ T.pack c) - else writeFile f c - isNameChar c = isAlphaNum c || c == '-' - insertProjName c = T.unpack $ T.replace - (T.pack "projname") - (T.pack $ filter isNameChar projName) c - ------------------------------------------------------------------------------- -initProject :: [String] -> IO () -initProject args = do - case getOpt Permute options args of - (flags, _, []) - | InitHelp `elem` flags -> do putStrLn initUsage - exitFailure - | otherwise -> init' flags - - (_, _, errs) -> do putStrLn $ concat errs - putStrLn initUsage - exitFailure - where - initUsage = usageInfo "Usage\n snap init\n\nOptions:" options - - options = - [ Option ['b'] ["barebones"] (NoArg InitBareBones) - "Depend only on -core and -server" - , Option ['h'] ["help"] (NoArg InitHelp) - "Print this message" - , Option ['e'] ["extensions"] (NoArg InitExtensions) - "Depend on snap w/ extensions (default)" - ] - - init' flags = do - cur <- getCurrentDirectory - let dirs = splitDirectories cur - projName = last dirs - setup' = setup projName - case flags of - (_:_) | InitBareBones `elem` flags -> setup' tDirBareBones - | InitExtensions `elem` flags -> setup' tDirDefault - _ -> setup' tDirDefault - - ------------------------------------------------------------------------------- -main :: IO () -main = do - args <- getArgs - case args of - ("init":args') -> initProject args' - _ -> do putStrLn usage - exitFailure diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs deleted file mode 100644 --- a/src/Snap/StarterTH.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Snap.StarterTH where - ------------------------------------------------------------------------------- -import qualified Data.Foldable as F -import Data.List -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import System.Directory.Tree ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- Convenience types -type FileData = (String, String) -type DirData = FilePath - - ------------------------------------------------------------------------------- --- Gets all the directorys in a DirTree -getDirs :: [FilePath] -> DirTree a -> [FilePath] -getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) : - concatMap (getDirs (n:prefix)) c -getDirs _ (File _ _) = [] -getDirs _ (Failed _ _) = [] - - ------------------------------------------------------------------------------- --- Reads a directory and returns a tuple of the list of all directories --- encountered and a list of filenames and content strings. -readTree :: FilePath -> IO ([DirData], [FileData]) -readTree dir = do - d <- readDirectory $ dir ++ "/." - let ps = zipPaths $ "" :/ (free d) - fd = F.foldr (:) [] ps - dirs = tail . getDirs [] $ free d - - return (dirs, fd) - - ------------------------------------------------------------------------------- --- Calls readTree and returns it's value in a quasiquote. -dirQ :: FilePath -> Q Exp -dirQ tplDir = do - d <- runIO . readTree $ "project_template/" ++ tplDir - lift d - - ------------------------------------------------------------------------------- --- Creates a declaration assigning the specified name the value returned by --- dirQ. -buildData :: String -> FilePath -> Q [Dec] -buildData dirName tplDir = do - let dir = mkName dirName - - typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |] - v <- valD (varP dir) (normalB $ dirQ tplDir) [] - return [typeSig, v] diff --git a/test/bad.tpl b/test/bad.tpl new file mode 100644 --- /dev/null +++ b/test/bad.tpl @@ -0,0 +1,1 @@ += 1.6 - -Executable testsuite - hs-source-dirs: suite - main-is: TestSuite.hs - - build-depends: - QuickCheck >= 2.3.0.2, - base >= 4 && < 5, - bytestring == 0.9.*, - directory, - filepath, - HUnit >= 1.2 && < 2, - http-enumerator >= 0.2.1.5 && <0.3, - process == 1.*, - test-framework >= 0.3.1 && <0.4, - test-framework-hunit >= 0.2.5 && < 0.3, - test-framework-quickcheck2 >= 0.2.6 && < 0.3 - - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded - -fno-warn-unused-do-bind 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/Blackbox/Tests.hs b/test/suite/Blackbox/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Blackbox/Tests.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Blackbox.Tests + ( tests + , remove + , removeDir + ) where + +------------------------------------------------------------------------------ +import Control.Exception (catch, finally, throwIO) +import Control.Monad +import Control.Monad.Trans +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Monoid +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T +import Network.Http.Client +import Prelude hiding (catch) +import System.Directory +import System.FilePath +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, path) +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +testServer :: String +testServer = "http://127.0.0.1" + + +------------------------------------------------------------------------------ +testPort :: String +testPort = "9753" + + +------------------------------------------------------------------------------ +-- | The server uri, without the leading slash. +testServerUri :: String +testServerUri = testServer ++ ":" ++ testPort + + +------------------------------------------------------------------------------ +-- | The server url, with the leading slash. +testServerUrl :: String +testServerUrl = testServerUri ++ "/" + + + -------------------- + -- TEST LOADER -- + -------------------- + +------------------------------------------------------------------------------ +tests :: Test +tests = testGroup "non-cabal-tests" + [ requestTest "hello" "hello world" + , requestTest "index" "index page\n" + , requestTest "" "index page\n" + , requestTest "splicepage" "splice page contents of the app splice\n" + , requestTest "routeWithSplice" "routeWithSplice: foo snaplet data stringz" + , requestTest "routeWithConfig" "routeWithConfig: topConfigValue" + , requestTest "foo/foopage" "foo template page\n" + , requestTest "foo/fooConfig" "fooValue" + , requestTest "foo/fooRootUrl" "foo" + , requestTest "barconfig" "barValue" + , requestTest "bazpage" "baz template page \n" + , requestTest "bazpage2" "baz template page contents of the bar splice\n" + , requestTest "bazpage3" "baz template page \n" + , requestTest "bazpage4" "baz template page \n" + , requestTest "barrooturl" "url" + , requestExpectingErrorPrefix "bazbadpage" 500 "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found." + , requestTest "foo/fooSnapletName" "foosnaplet" + + , fooConfigPathTest + + -- Test the embedded snaplet + , requestTest "embed/heist/embeddedpage" "embedded snaplet page \n" + , requestTest "embed/aoeuhtns" "embedded snaplet page splice value42\n" + , requestTest "embed/heist/onemoredir/extra" "This is an extra template\n" + + -- This set of tests highlights the differences in the behavior of the + -- get... functions from MonadSnaplet. + , fooHandlerConfigTest + , barHandlerConfigTest + , bazpage5Test + , bazConfigTest + , requestTest "sessionDemo" "[(\"foo\",\"bar\")]\n" + , reloadTest + ] + + +------------------------------------------------------------------------------ +testName :: String -> String +testName uri = "internal/" ++ uri +--testName = id + +------------------------------------------------------------------------------ +requestTest :: String -> Text -> Test +requestTest url desired = testCase (testName url) $ requestTest' url desired + + +------------------------------------------------------------------------------ +requestTest' :: String -> Text -> IO () +requestTest' url desired = do + actual <- get (S.pack $ testServerUrl ++ url) concatHandler + assertEqual url desired (T.decodeUtf8 $ L.fromChunks [actual]) + + +------------------------------------------------------------------------------ +requestExpectingErrorPrefix :: String -> Int -> Text -> Test +requestExpectingErrorPrefix url status desired = + testCase (testName url) $ requestExpectingErrorPrefix' url status desired + + +------------------------------------------------------------------------------ +requestExpectingErrorPrefix' :: String -> Int -> Text -> IO () +requestExpectingErrorPrefix' url status desired = do + let fullUrl = testServerUrl ++ url + get (S.pack fullUrl) $ \resp is -> do + assertEqual ("Status code: "++fullUrl) status + (getStatusCode resp) + res <- concatHandler resp is + assertBool fullUrl $ desired `T.isPrefixOf` (T.decodeUtf8 $ L.fromChunks [res]) + + +------------------------------------------------------------------------------ +fooConfigPathTest :: Test +fooConfigPathTest = testCase (testName "foo/fooFilePath") $ do + b <- liftM L.unpack $ grab "/foo/fooFilePath" + assertRelativelyTheSame b "snaplets/foosnaplet" + + +------------------------------------------------------------------------------ +assertRelativelyTheSame :: FilePath -> FilePath -> IO () +assertRelativelyTheSame p expected = do + b <- makeRelativeToCurrentDirectory p + assertEqual ("expected " ++ expected) expected b + + +------------------------------------------------------------------------------ +grab :: MonadIO m => String -> m L.ByteString +grab path = liftIO $ liftM (L.fromChunks . (:[])) $ + get (S.pack $ testServerUri ++ path) concatHandler + + +------------------------------------------------------------------------------ +testWithCwd :: String + -> (String -> L.ByteString -> Assertion) + -> Test +testWithCwd uri f = testCase (testName uri) $ + testWithCwd' uri f + + +------------------------------------------------------------------------------ +testWithCwd' :: String + -> (String -> L.ByteString -> Assertion) + -> Assertion +testWithCwd' uri f = do + b <- grab slashUri + cwd <- getCurrentDirectory + + f cwd b + + where + slashUri = '/' : uri + + +------------------------------------------------------------------------------ +fooHandlerConfigTest :: Test +fooHandlerConfigTest = testWithCwd "foo/handlerConfig" $ \cwd b -> do + let response = L.fromChunks [ "([\"app\"],\"" + , S.pack cwd + , "/snaplets/foosnaplet\"," + , "Just \"foosnaplet\",\"A demonstration " + , "snaplet called foo.\",\"foo\")" ] + assertEqual "" response b + + +------------------------------------------------------------------------------ +barHandlerConfigTest :: Test +barHandlerConfigTest = testWithCwd "bar/handlerConfig" $ \cwd b -> do + let response = L.fromChunks [ "([\"app\"],\"" + , S.pack cwd + , "/snaplets/baz\"," + , "Just \"baz\",\"An example snaplet called " + , "bar.\",\"\")" ] + assertEqual "" response b + + +------------------------------------------------------------------------------ +-- bazpage5 uses barsplice bound by renderWithSplices at request time +bazpage5Test :: Test +bazpage5Test = testWithCwd "bazpage5" $ \cwd b -> do + let response = L.fromChunks [ "baz template page ([\"app\"],\"" + , S.pack cwd + , "/snaplets/baz\"," + , "Just \"baz\",\"An example snaplet called " + , "bar.\",\"\")\n" ] + assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b) + + +------------------------------------------------------------------------------ +-- bazconfig uses two splices, appconfig and fooconfig. appconfig is bound with +-- the non type class version of addSplices in the main app initializer. +-- fooconfig is bound by addSplices in fooInit. +bazConfigTest :: Test +bazConfigTest = testWithCwd "bazconfig" $ \cwd b -> do + let response = L.fromChunks [ + "baz config page ([],\"" + , S.pack cwd + , "\",Just \"app\"," -- TODO, right? + , "\"Test application\",\"\") " + , "([\"app\"],\"" + , S.pack cwd + , "/snaplets/foosnaplet\"," + , "Just \"foosnaplet\",\"A demonstration snaplet " + , "called foo.\",\"foo\")\n" + ] + + assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b) + + +------------------------------------------------------------------------------ +expect404 :: String -> IO () +expect404 url = do + get (S.pack $ testServerUrl ++ url) $ \resp i -> do + case getStatusCode resp of + 404 -> return () + _ -> assertFailure "expected 404" + + +------------------------------------------------------------------------------ +request404Test :: String -> Test +request404Test url = testCase (testName url) $ expect404 url + + +remove :: FilePath -> IO () +remove f = do + exists <- doesFileExist f + when exists $ removeFile f + + +removeDir :: FilePath -> IO () +removeDir d = do + exists <- doesDirectoryExist d + when exists $ removeDirectoryRecursive "snaplets/foosnaplet" + + +------------------------------------------------------------------------------ +reloadTest :: Test +reloadTest = testCase "internal/reload-test" $ do + let goodTplOrig = "good.tpl" + let badTplOrig = "bad.tpl" + let goodTplNew = "snaplets" "heist" + "templates" "good.tpl" + let badTplNew = "snaplets" "heist" + "templates" "bad.tpl" + + goodExists <- doesFileExist goodTplNew + badExists <- doesFileExist badTplNew + + assertBool "good.tpl exists" (not goodExists) + assertBool "bad.tpl exists" (not badExists) + expect404 "bad" + + copyFile badTplOrig badTplNew + expect404 "good" + expect404 "bad" + + flip finally (remove badTplNew) $ + testWithCwd' "admin/reload" $ \cwd' b -> do + let cwd = T.pack cwd' + + let prefix = T.intercalate "\n" + [ "Error reloading site!" + , "" + , "Initializer threw an exception..." + , T.concat + [ cwd, "/snaplets/heist/templates/bad.tpl \"" + , cwd, "/snaplets/heist/templates/bad.tpl\" (line 2, column 1):" + ] + , "unexpected end of input" + , "expecting \"=\", \"/\" or \">\"" + + -- Building with the latest dependency versions produces the following: + -- "CallStack (from HasCallStack):" + -- " error, called at src/Snap/Snaplet/Heist/Internal.hs:75:35 in main:Snap.Snaplet.Heist.Internal" + ] + + let suffix = T.intercalate "\n" + [ "...but before it died it generated the following output:" + , "Initializing app @ /" + , "Initializing heist @ /heist" + , "" + , "" + ] + + let response = T.decodeUtf8 b + + assertEqual "admin/reload" prefix (T.take (T.length prefix) response) + assertEqual "admin/reload" suffix (T.takeEnd (T.length suffix) response) + + copyFile goodTplOrig goodTplNew + + testWithCwd' "admin/reload" $ \cwd' b -> do -- TODO/NOTE: Needs cleanup + let cwd = S.pack cwd' + let response = L.fromChunks [ + "Initializing app @ /\nInitializing heist @ ", + "/heist\n...loaded 9 templates from ", + cwd, + "/snaplets/heist/templates\nInitializing CookieSession ", + "@ /session\nInitializing foosnaplet @ /foo\n...adding 1 ", + "templates from ", + cwd, + "/snaplets/foosnaplet/templates with route prefix ", + "foo/\nInitializing baz @ /\n...adding 2 templates from ", + cwd, + "/snaplets/baz/templates with route prefix /\nInitializing ", + "embedded @ /\nInitializing heist @ /heist\n...loaded ", + "1 templates from ", + cwd, + "/snaplets/embedded/snaplets/heist/templates\n...adding ", + "1 templates from ", + cwd, + "/snaplets/embedded/extra-templates with route prefix ", + "onemoredir/\n...adding 0 templates from ", + cwd, + "/templates with route prefix extraTemplates/\n", + "Initializing JsonFileAuthManager @ ", + "/auth\nSite successfully reloaded.\n" + ] + + assertEqual "admin/reload" response b + + requestTest' "good" "Good template\n" + + diff --git a/test/suite/SafeCWD.hs b/test/suite/SafeCWD.hs new file mode 100644 --- /dev/null +++ b/test/suite/SafeCWD.hs @@ -0,0 +1,33 @@ +module SafeCWD + ( inDir + , removeDirectoryRecursiveSafe + ) where + +import Control.Concurrent.QSem +import Control.Exception +import Control.Monad +import System.Directory +import System.IO.Unsafe + +sem :: QSem +sem = unsafePerformIO $ newQSem 1 +{-# NOINLINE sem #-} + + +inDir :: Bool -> FilePath -> IO a -> IO a +inDir startClean dir action = bracket before after (const action) + where + before = do + waitQSem sem + cwd <- getCurrentDirectory + when startClean $ removeDirectoryRecursiveSafe dir + createDirectoryIfMissing True dir + setCurrentDirectory dir + return cwd + after cwd = do + setCurrentDirectory cwd + signalQSem sem + + +removeDirectoryRecursiveSafe p = + doesDirectoryExist p >>= flip when (removeDirectoryRecursive p) 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/LensT/Tests.hs b/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Snap.Snaplet.Internal.LensT.Tests (tests) where + +import Control.Lens +import Control.Applicative +import Control.Category +import Control.Monad.Identity +import Control.Monad.State.Strict +import Prelude hiding (catch, (.)) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, path) + + +------------------------------------------------------------------------------ +import Snap.Snaplet.Internal.LensT + + +------------------------------------------------------------------------------ +data TestType = TestType { + _int0 :: Int + , _sub :: TestSubType +} deriving (Show) + +data TestSubType = TestSubType { + _sub0 :: Int + , _sub1 :: Int + , _bot :: TestBotType +} deriving (Show) + +data TestBotType = TestBotType { + _bot0 :: Int +} deriving (Show) + +makeLenses ''TestType +makeLenses ''TestSubType +makeLenses ''TestBotType + + +------------------------------------------------------------------------------ +defaultState :: TestType +defaultState = TestType 1 $ TestSubType 2 999 $ TestBotType 3 + + +------------------------------------------------------------------------------ +tests :: Test +tests = testGroup "Snap.Snaplet.Internal.LensT" + [ testfmap + , testApplicative + , testMonadState + ] + + +------------------------------------------------------------------------------ +testfmap :: Test +testfmap = testCase "lensed/fmap" $ do +-- x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState + let x = fst $ runIdentity (runLensT (fmap (*2) three) (sub . bot) defaultState) + assertEqual "fmap" 6 x + + let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState) + + assertEqual "fmap2" (12 :: Int) y + assertEqual "lens" (13 :: Int) $ _bot0 $ _bot $ _sub s' + return () + + where +-- three :: LensT TestType TestBotType IO Int + three = return 3 + + twiddle = do + modify $ \(TestBotType x) -> TestBotType (x+10) + fmap (+9) three + + +------------------------------------------------------------------------------ +testApplicative :: Test +testApplicative = testCase "lensed/applicative" $ do +-- x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState + let x = fst $ runIdentity (runLensT (pure (*2) <*> three) (sub . bot) defaultState) + assertEqual "fmap" 6 x + + let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState) + + assertEqual "fmap2" (12::Int) y + assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s' + return () + + where +-- three :: LensT TestType TestBotType IO Int + three = pure 3 + + twiddle = do + modify $ \(TestBotType x) -> TestBotType (x+10) + pure [] *> (pure (+9) <*> three) <* pure [] + + +------------------------------------------------------------------------------ +testMonadState :: Test +testMonadState = testCase "lens/MonadState" $ do +-- s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState + let s = snd $ runIdentity (runLensT go (sub . bot . bot0) defaultState) + + assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s + assertEqual "sub0" 3 $ _sub0 $ _sub s + assertEqual "sub1" 999 $ _sub1 $ _sub s + + where +-- go :: LensT TestType Int IO () + go = do + modify (*2) + modify (+3) + withTop sub go' + +-- go' :: LensT TestType TestSubType IO () + go' = do + a <- with sub0 get + with sub0 $ put $ a+1 + + diff --git a/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs b/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Snap.Snaplet.Internal.Lensed.Tests (tests) where + +import Control.Applicative +import Control.Category +import Control.Exception +import Control.Lens +import Control.Monad.State.Lazy +import Prelude hiding (catch, (.)) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test, path) + + +------------------------------------------------------------------------------ +import Snap.Snaplet.Internal.Lensed + + +------------------------------------------------------------------------------ +data TestType = TestType { + _int0 :: Int + , _sub :: TestSubType +} deriving (Show) + +data TestSubType = TestSubType { + _sub0 :: Int + , _sub1 :: Int + , _bot :: TestBotType +} deriving (Show) + +data TestBotType = TestBotType { + _bot0 :: Int +} deriving (Show) + +makeLenses ''TestType +makeLenses ''TestSubType +makeLenses ''TestBotType + + +------------------------------------------------------------------------------ +defaultState :: TestType +defaultState = TestType 1 $ TestSubType 2 999 $ TestBotType 3 + + +------------------------------------------------------------------------------ +tests = testGroup "Snap.Snaplet.Internal.Lensed" + [ testfmap + , testApplicative + , testMonadState + ] + + +------------------------------------------------------------------------------ +testfmap :: Test +testfmap = testCase "lensed/fmap" $ do + x <- evalStateT (lensedAsState (fmap (*2) three) (sub . bot)) defaultState + assertEqual "fmap" 6 x + + (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState + + assertEqual "fmap2" 12 y + assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s' + return () + + where + three :: Lensed TestType TestBotType IO Int + three = return 3 + + twiddle = do + modify $ \(TestBotType x) -> TestBotType (x+10) + fmap (+9) three + + +------------------------------------------------------------------------------ +testApplicative :: Test +testApplicative = testCase "lensed/applicative" $ do + x <- evalStateT (lensedAsState (pure (*2) <*> three) (sub . bot)) defaultState + assertEqual "fmap" 6 x + + (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState + + assertEqual "fmap2" (12::Int) y + assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s' + return () + + where + three :: Lensed TestType TestBotType IO Int + three = pure 3 + + twiddle = do + modify $ \(TestBotType x) -> TestBotType (x+10) + pure [] *> (pure (+9) <*> three) <* pure [] + + +------------------------------------------------------------------------------ +testMonadState :: Test +testMonadState = testCase "lens/MonadState" $ do + s <- execStateT (lensedAsState go (sub . bot . bot0)) defaultState + + assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s + assertEqual "sub0" 3 $ _sub0 $ _sub s + assertEqual "sub1" 1000 $ _sub1 $ _sub s + + where + go :: Lensed TestType Int IO () + go = do + modify (*2) + modify (+3) + withTop sub go' + + go' :: Lensed TestType TestSubType IO () + go' = do + a <- with sub0 get + with sub0 $ put $ a+1 + embed sub1 go'' + + go'' :: Lensed TestSubType Int IO () + go'' = modify (+1) + + +eat :: SomeException -> IO () +eat _ = return () + +qqq = defaultMainWithArgs [tests] ["--plain"] `catch` eat diff --git a/test/suite/Snap/Snaplet/Internal/RST/Tests.hs b/test/suite/Snap/Snaplet/Internal/RST/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Internal/RST/Tests.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} + +module Snap.Snaplet.Internal.RST.Tests + ( tests ) where + +import Control.Applicative +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.State +import Prelude hiding (catch, (.)) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test, path) + +import Snap.Snaplet.Internal.RST + + +tests :: Test +tests = testGroup "Snap.Snaplet.Internal.RST" + [ testExec + , testEval + , testFail + , testAlternative + ] + + +testEval :: Test +testEval = testProperty "RST/execRST" prop + where + prop x = runIdentity (evalRST m x undefined) == x + m :: RST Int () Identity Int + m = ask + +testExec :: Test +testExec = testProperty "RST/execRST" prop + where + prop x = runIdentity (execRST m undefined x) == x + m :: RST () Int Identity Int + m = get + +testFail :: Test +testFail = testCase "RST/fail" $ + assertEqual "RST fail" rstFail Nothing + +testAlternative :: Test +testAlternative = testCase "RST/Alternative" $ do + assertEqual "Alternative instance" rstAlt (Just (5, 1)) + assertEqual "Alternative instance" rstAlt2 (Just (5, 1)) + +addEnv :: Monad m => RST Int Int m () +addEnv = do + v <- ask + modify (+v) + +rstAlt :: Maybe (Int, Int) +rstAlt = runRST (addEnv >> (empty <|> (return 5))) 1 0 + +rstAlt2 :: Maybe (Int, Int) +rstAlt2 = runRST (addEnv >> ((return 5) <|> empty)) 1 0 + +rstFail :: Maybe Int +rstFail = evalRST (fail "foo") (0 :: Int) (0 :: Int) + diff --git a/test/suite/Snap/Snaplet/Internal/Tests.hs b/test/suite/Snap/Snaplet/Internal/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Internal/Tests.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} + +module Snap.Snaplet.Internal.Tests + ( tests, initTest ) where + +------------------------------------------------------------------------------ +import Control.Lens (makeLenses) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Text (Text) +import Prelude hiding (catch, (.)) +import System.Directory (getCurrentDirectory) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.SmallCheck (testProperty) +import Test.HUnit hiding (Test, path) +import Test.SmallCheck ((==>)) +------------------------------------------------------------------------------ +import Snap.Snaplet.Internal.Initializer +import Snap.Snaplet.Internal.Types + + + --------------------------------- + -- TODO: this module is a mess -- + --------------------------------- + + +------------------------------------------------------------------------------ +data Foo = Foo Int + +data Bar = Bar Int + + +data App = App + { _foo :: Snaplet Foo + , _bar :: Snaplet Bar + } + +makeLenses ''App + +--showConfig :: SnapletConfig -> IO () +--showConfig c = do +-- putStrLn "SnapletConfig:" +-- print $ _scAncestry c +-- print $ _scFilePath c +-- print $ _scId c +-- print $ _scDescription c +-- print $ _scRouteContext c +-- putStrLn "" + + +------------------------------------------------------------------------------ +assertGet :: (MonadIO m, Show a, Eq a) => String -> m a -> a -> m () +assertGet name getter val = do + v <- getter + liftIO $ assertEqual name val v + + +------------------------------------------------------------------------------ +configAssertions :: (MonadSnaplet m, MonadIO (m b v)) + => [Char] + -> ([Text], FilePath, Maybe Text, Text, ByteString) + -> m b v () +configAssertions prefix (a,f,n,d,r) = do + assertGet (prefix ++ "ancestry" ) getSnapletAncestry a + assertGet (prefix ++ "file path" ) getSnapletFilePath f + assertGet (prefix ++ "name" ) getSnapletName n + assertGet (prefix ++ "description" ) getSnapletDescription d + assertGet (prefix ++ "route context" ) getSnapletRootURL r + + +------------------------------------------------------------------------------ +appInit :: SnapletInit App App +appInit = makeSnaplet "app" "Test application" Nothing $ do + cwd <- liftIO getCurrentDirectory + + configAssertions "root " + ([], cwd, Just "app", "Test application", "") + + assertGet "environment" getEnvironment "devel" + + f <- nestSnaplet "foo" foo $ fooInit + b <- nestSnaplet "bar" bar $ barInit + return $ App f b + + +------------------------------------------------------------------------------ +fooInit :: SnapletInit b Foo +fooInit = makeSnaplet "foo" "Foo Snaplet" Nothing $ do + cwd <- liftIO getCurrentDirectory + let dir = cwd ++ "/snaplets/foo" + + configAssertions "foo " + (["app"], dir, Just "foo", "Foo Snaplet", "foo") + return $ Foo 42 + + +------------------------------------------------------------------------------ +barInit :: SnapletInit b Bar +barInit = makeSnaplet "bar" "Bar Snaplet" Nothing $ do + cwd <- liftIO getCurrentDirectory + let dir = cwd ++ "/snaplets/bar" + configAssertions "bar " + (["app"], dir, Just "bar", "Bar Snaplet", "bar") + return $ Bar 2 + + +------------------------------------------------------------------------------ +initTest :: IO () +initTest = do + (out,_,_) <- runSnaplet Nothing appInit + + -- note from gdc: wtf? + if out == "aoeu" + then putStrLn "Something really strange" + else return () + + +------------------------------------------------------------------------------ +tests :: Test +tests = testGroup "Snap.Snaplet.Internal" + [ testCase "initializer tests" initTest + , testProperty "buildPath generates no double slashes" doubleSlashes + ] + +--doubleSlashes :: Monad m => [String] -> Property m +doubleSlashes arrStr = noSlashes ==> not (B.isInfixOf "//" $ buildPath arr) + where + arr = map B.pack arrStr + noSlashes = not $ or $ map (B.elem '/') arr + + 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,57 +1,82 @@ module Snap.TestCommon where -import Control.Concurrent -import Control.Exception -import Control.Monad (when) -import System.Cmd -import System.Directory -import System.Exit -import System.FilePath -import System.Process +------------------------------------------------------------------------------ +import Control.Exception (try, SomeException) +import Control.Monad.Trans (lift) +import qualified Data.Text as T +import qualified GHC.Read as R +import Test.HUnit (Assertion, assertFailure, assertBool) +import qualified Text.ParserCombinators.ReadPrec as R +------------------------------------------------------------------------------ +import Snap.Core +import Snap.Snaplet +import Snap.Snaplet.Heist +import Heist.Interpreted -testGeneratedProject :: String -- ^ project name and directory - -> String -- ^ arguments to @snap init@ - -> String -- ^ arguments to @cabal install@ - -> Int -- ^ port to run http server on - -> IO () -- ^ action to run when the server goes up - -> IO () -testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort - testAction = bracket initialize cleanup (const testAction) - where - initialize = do - cwd <- getCurrentDirectory - let projectPath = cwd projName - flip onException (setCurrentDirectory cwd >> - removeDirectoryRecursive projectPath) $ do - makeWorkDirectory projectPath - setCurrentDirectory projectPath - systemOrDie $ "snap init " ++ snapInitArgs - systemOrDie $ "cabal install " ++ cabalInstallArgs - let cmd = ("." "dist" "build" projName projName) - ++ " -p " ++ show httpPort - putStrLn $ "Running \"" ++ cmd ++ "\"" - pHandle <- runCommand cmd - waitABit - return (cwd, projectPath, pHandle) - cleanup (cwd, projectPath, pHandle) = do - setCurrentDirectory cwd - terminateProcess pHandle - waitForProcess pHandle - removeDirectoryRecursive projectPath +------------------------------------------------------------------------------ +expectException :: String -> IO a -> IO () +expectException s m = do + r <- try m + case r of + Left (e::SomeException) -> length (show e) `seq` return () + Right _ -> assertFailure s - waitABit = threadDelay $ 2*10^(6::Int) -systemOrDie :: String -> IO () -systemOrDie s = do - putStrLn $ "Running \"" ++ s ++ "\"" - system s >>= check +------------------------------------------------------------------------------ +showTestCase :: Show a => a -> Assertion +showTestCase a = assertBool "Show instance failed" $ + ((showsPrec 5 a) "" == show a) + && (showList [a]) "" == "[" ++ show a ++ "]" + + +------------------------------------------------------------------------------ +readTestCase :: (Eq a, Show a, Read a) => a -> Assertion +readTestCase a = assertBool "Read instance failed" $ + ( ((readsPrec 1) (show a)) == ([(a,"")])) + && ((readList ("[" ++ show a ++ "]")) == [([a],"")]) + && ((R.readPrec_to_S (R.readPrec) 5) (show a) == [(a,"")]) + && ((R.readPrec_to_S (R.readListPrec) 5) ("[" ++ show a ++ "]") + == [([a],"")]) + + +------------------------------------------------------------------------------ +ordTestCase :: (Eq a, Ord a) => a -> a -> Assertion +ordTestCase a b = assertBool "Ord instance failed" $ + low <= high + && (if low /= high + then low < high && compare low high == LT && high > low + else low == high && compare low high == EQ) where - check ExitSuccess = return () - check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'" + low = min a b + high = max a b -makeWorkDirectory :: FilePath -> IO () -makeWorkDirectory p = do - doesDirectoryExist p >>= flip when (removeDirectoryRecursive p) - createDirectory p +------------------------------------------------------------------------------ +eqTestCase :: (Eq a) => a -> a -> Assertion +eqTestCase a b = assertBool "Eq instance failed" $ + if a == b + then (a /= b) == False + else (a /= b) == True + + +------------------------------------------------------------------------------ +genericConfigString :: (MonadSnaplet m, Monad (m b v)) => m b v T.Text +genericConfigString = do + a <- getSnapletAncestry + b <- getSnapletFilePath + c <- getSnapletName + d <- getSnapletDescription + e <- getSnapletRootURL + return $ T.pack $ show (a,b,c,d,e) + + +------------------------------------------------------------------------------ +handlerConfig :: Handler b v () +handlerConfig = writeText =<< genericConfigString + + +------------------------------------------------------------------------------ +shConfigSplice :: SnapletLens (Snaplet b) v -> SnapletISplice b +shConfigSplice _lens = textSplice =<< lift (with' _lens genericConfigString) + diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -1,52 +1,105 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Control.Monad -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Char8 as S -import qualified Network.HTTP.Enumerator as HTTP -import Test.Framework (defaultMain, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test, path) +------------------------------------------------------------------------------ +import Control.Concurrent +import Control.Exception (SomeException (..), bracket, catch, finally) +import Control.Monad (void) +import System.Directory (getCurrentDirectory, setCurrentDirectory) +import System.FilePath (()) +import System.IO -import Snap.TestCommon +------------------------------------------------------------------------------ +import qualified Blackbox.Tests +import Prelude (Bool (False), IO, Int, Maybe (Nothing), Monad (..), Num (..), flip, return, ($), (.), (^)) +import Snap.Http.Server (simpleHttpServe) +import Snap.Http.Server.Config +import Snap.Snaplet +import qualified Snap.Snaplet.Auth.Tests +import qualified Snap.Snaplet.Config.Tests +import qualified Snap.Snaplet.Heist.Tests +import qualified Snap.Snaplet.Internal.Lensed.Tests +import qualified Snap.Snaplet.Internal.LensT.Tests +import qualified Snap.Snaplet.Internal.RST.Tests +import qualified Snap.Snaplet.Internal.Tests +import Snap.Snaplet.Test.Common.App +import qualified Snap.Snaplet.Test.Tests +import Test.Framework +import SafeCWD + +------------------------------------------------------------------------------ main :: IO () -main = defaultMain tests - where tests = [ testBarebones - , testDefault - ] +main = do + -- chdir into test/ + cwd <- getCurrentDirectory + setCurrentDirectory (cwd "test") + Blackbox.Tests.remove + "snaplets/heist/templates/bad.tpl" + Blackbox.Tests.remove + "snaplets/heist/templates/good.tpl" + {- Why were we removing this? + Blackbox.Tests.removeDir "snaplets/foosnaplet" + -} -testBarebones :: Test -testBarebones = testCase "snap/barebones" go - where - go = testGeneratedProject "barebonesTest" - "-b" - "" - port - testIt - port = 9990 - testIt = do - body <- HTTP.simpleHttp "http://127.0.0.1:9990" - assertEqual "server not up" "hello world" body +-- (tid, mvar) <- inDir False "non-cabal-appdir" startServer + (tid, mvar) <- inDir False "." startServer + defaultMain [tests] + `finally` do + setCurrentDirectory cwd + killThread tid + putStrLn "waiting for termination mvar" + takeMVar mvar -testDefault :: Test -testDefault = testCase "snap/default" go - where - go = testGeneratedProject "defaultTest" - "" - "" - port - testIt - port = 9991 - testIt = do - body <- liftM (S.concat . L.toChunks) $ - HTTP.simpleHttp "http://127.0.0.1:9991" - assertBool "response contains phrase 'it works!'" - $ "It works!" `S.isInfixOf` body + where tests = mutuallyExclusive $ + testGroup "snap" [ internalServerTests + , Snap.Snaplet.Auth.Tests.tests + , Snap.Snaplet.Test.Tests.tests + , Snap.Snaplet.Heist.Tests.heistTests + , Snap.Snaplet.Config.Tests.configTests + , Snap.Snaplet.Internal.RST.Tests.tests + , Snap.Snaplet.Internal.LensT.Tests.tests + , Snap.Snaplet.Internal.Lensed.Tests.tests + ] --- TODO: test hint code here + +------------------------------------------------------------------------------ +internalServerTests :: Test +internalServerTests = + mutuallyExclusive $ + testGroup "internal server tests" + [ Blackbox.Tests.tests + , Snap.Snaplet.Internal.Lensed.Tests.tests + , Snap.Snaplet.Internal.LensT.Tests.tests + , Snap.Snaplet.Internal.RST.Tests.tests + , Snap.Snaplet.Internal.Tests.tests + ] + + +------------------------------------------------------------------------------ +startServer :: IO (ThreadId, MVar ()) +startServer = do + mvar <- newEmptyMVar + t <- forkIOWithUnmask $ \restore -> + serve restore mvar (setPort 9753 . + setBind "127.0.0.1" $ defaultConfig) appInit + threadDelay $ 2*10^(6::Int) + return (t, mvar) + + where + gobble m = void m `catch` \(_::SomeException) -> return () + serve restore mvar config initializer = + flip finally (putMVar mvar ()) $ + gobble $ restore $ do + hPutStrLn stderr "initializing snaplet" + bracket (runSnaplet Nothing initializer) + (\(_, _, doCleanup) -> doCleanup) + (\(_, handler, _ ) -> do + (conf, site) <- combineConfig config handler + hPutStrLn stderr "bringing up server" + simpleHttpServe conf site)