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 @@ -4,3 +4,4 @@ Carl Howells Chris Smith Jurriën Stutterheim +Alfredo Di Napoli diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,17 +1,16 @@ -Snap Framework +Snap Framework [![Hackage Status](https://img.shields.io/hackage/v/snap.svg)](https://hackage.haskell.org/package/snap) ============== -Snap is a web framework for Haskell, based on iteratee I/O (as [popularized by -Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). For more -information about Snap, read the `README.SNAP.md` or visit the Snap project -website at http://www.snapframework.com/. +[![GitHub CI](https://github.com/snapframework/snap/workflows/CI/badge.svg)](https://github.com/snapframework/snap/actions) +Snap is a simple and fast web development framework and server written in +Haskell. For more information about Snap, read the `README.SNAP.md` or visit +the Snap project website at http://www.snapframework.com/. + ## Library contents This is top-level project for the Snap Framework, which contains: - * a command-line utility for creating initial Snap applications - * a library allowing Snap applications to recompile actions on the fly in development mode, with no performance loss in production mode. @@ -19,17 +18,26 @@ * a "snaplet" API allowing web applications to be build from composable pieces. +The command-line utility `snap` for creating initial Snap applications used to +be a part of this package. As of version 1.0, the snap command-line utility is +no longer provided by this package. It is now provided by the package +[`snap-templates`](https://github.com/snapframework/snap-templates). + Building snap ============= -The snap tool and library are built using -[Cabal](http://www.haskell.org/cabal/) and -[Hackage](http://hackage.haskell.org/packages/hackage.html). Just run +After you clone the repository, change to the newly created snap directory and +run + git submodule update --init --recursive + ./init-sandbox.sh cabal install -from the `snap` toplevel directory. - +(You may want to look at pull.sh or pullLatestMaster.sh.) +This updates all the Snap Framework dependencies to the correct version, +creates a sandbox, and installs everything. The snap library is built using +[Cabal](http://www.haskell.org/cabal/) and +[Hackage](http://hackage.haskell.org/packages/hackage.html). ## Building the Haddock Documentation @@ -40,23 +48,24 @@ ## Building the testsuite -To build the test suite, `cd` into the `test/` directory and run +To build the test suite, run - $ cabal configure + $ cabal clean + $ cabal configure --enable-tests --enable-library-coverage $ cabal build + $ cabal install --enable-tests From here you can invoke the testsuite by running: $ ./runTestsAndCoverage.sh -The testsuite generates an `hpc` test coverage report in `test/dist/hpc`. +The testsuite generates an `hpc` test coverage report in `dist/hpc`. ## Roadmap to Understanding Snaplets -1. Read Tutorial.lhs which is in `project_template/tutorial/src`. +1. Read `Tutorial.lhs` which is in the `project_template/tutorial/src` directory of the `snap-templates` package. 2. Generate and read the haddock docs. 3. The test code has the nice property that it actually functions as a pretty good example app and covers a lot of the use cases. 4. If you're interested in the implementation, read design.md. - diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,34 @@ +## 1.1.3.3 + + - Update for GHC 9.8 + - Support aeson 2.2 + +## 1.1.3.2 + + - Update for GHC 9.0 through 9.6.2 + +## 1.1.3.1 + + - Update for GHC 8.10 + + + +## 1.1.1.0 + +### Added + + - GHC 8.4 support + +## 1.1.0.0 + +### Added + + - Support for aeson 1.x + - GHC 8.2 support + - New [lookupByEmail](src/Snap/Snaplet/Auth/AuthManager.hs#L62) function in the auth snaplet + +## 1.0.0.0 +### Removed + + - Removed support for `iteratees` in favor of + [io-streams](https://hackage.haskell.org/package/io-streams) diff --git a/design.md b/design.md new file mode 100644 --- /dev/null +++ b/design.md @@ -0,0 +1,129 @@ +# Snaplet Design + +The Snaplet infrastructure was designed with three high-level design goals: + +* Request local state +* Composability +* Availability + +First, request local state means that snaplets should be able to define their +own state that will be available during request processing. And that state +should be mutable with scope local to the request. + +Composability means that applications and snaplets should be interchangeable, +and you should be able to build them by gluing together other snaplets. + +Availability means that you should be able to access your application state +without threading it manually through parameters. + +## Handler + +Implementing the goal of request local state means that we need some kind of a +Handler monad that will look roughly like a state transformer built on top of +the Snap monad with the top level application data as the state. To implement +composability we also need an additional type parameter that can be changed to +match the scope of the current snaplet. We use the `withReader :: (r1 -> r2) +-> Reader r2 a -> Reader r1 a` pattern to manage scope changes, but in order +to make our state composably mutable, we need to enlist the help of lenses +instead of accessor functions. This allows us to keep only the top level +state and mutate the current context using the lens. + +The LensT monad is our implementation of this abstraction. It is a +combination of ReaderT and StateT (our RST abstraction). Since the lens is +not conceptually mutable in the same way as the actual state, it is stored in +the reader environment. The state monad part is used for the top level state +b, giving is the following newtype. + + newtype LensT b v s m a = LensT (RST (Lens b v) s m a) + +LensT comes with a (MonadReader (Lens b v)) instance for retrieving the lens +and a (MonadState v) instance that uses the lens transparently to achieve +stateful behavior with the type v. From here the definition of Handler is +fairly natural: + + newtype Handler b v a = + Handler (LensT (Snaplet b) (Snaplet v) (Snaplet b) Snap a) + +We use `LensT (Snaplet b) (Snaplet v)` instead of `LensT b (Snaplet v)` +because it is desirable to be able to use the identity lens to construct a +`Handler b b`. The only issue with this formulation is that the lens +manipulation functions provided by LensT are not what the end user needs. The +end user has a lens of type `Lens b (Snaplet v)` created by the `mkLabels` +function. But LensT's withXYZ functions need `Lens (Snaplet b) (Snaplet v)` +lenses. These can be derived easily by composing the user-supplied lens with +the internal lens `Lens (Snaplet a) a` derived from the definition of the +Snaplet data structure. + +NOTE: The above definition for Handler is no longer correct. We switched to a +slightly more specialized monad formulation called Lensed that avoids +traversal of the whole state hierarchy when the state is manipulated. Thanks +to Edward Kmett for pointing this out and writing the code for us. + +## Initializer + +The second important component of snaplets is initialization. This involves +setting up the state used by the handlers as well as defining a snaplet's +routes and cleanup actions, reading on-disk config files, and initializing and +interacting with other snaplets. `Initializer` still uses a LensT +implementation because it does not fit the more specialized case for which +Lensed is optimized. But it is similar enough that we can still refer to +snaplets using the same lenses that we use in Handlers. These similarities +are abstracted in the MonadSnaplet type class. + +During initialization, sometimes you want to modify the result of another +snaplet's initialization. For instance, maybe you want to add templates or +bind splices for a sitewide Heist snaplet. Or perhaps you want to add +controls to the admin panel snaplet. This involves modifying the state of +other snaplets. It would be nice to use the same lenses and scoped +modification via top-level state that we use in `Handler`. But in the +initializer we don't yet have a fully constructed top-level state object to +modify. So instead of actually modifying the state directly, we construct +modifier functions to be applied at the end of initialization. Since these +functions form a monoid, we can build them up using WriterT as LensT's +underlying monad. + +The `Initializer` monad is used for both initialization and application +reloading. When an application is reloaded from the browser, status and error +messages should go to the browser instead of the console. The printInfo +function sends messages to the appropriate place and should be used to +communicate all initializer status and errors. + +## Heist + +The Heist snaplet is a fairly complex snaplet that illustrates a number of +concepts that you may encounter while writing your own snaplets. The biggest +issue arises because Heist's TemplateState is parameterized by the handler +monad. This means that if you want to do something like a with transformation +with a lens `Lens b v` you will naturally want to apply the same +transformation to the Handler parameter of the TemplateState. Unfortunately, +due to Heist's design, this is computationally intensive, must be performed at +runtime, and requires that you have a bijection between b and v. To avoid +this issue, we only use the base application state, `TemplateState (Handler b +b)`. + +The basic functions for manipulating templates are not affected by this +decision. But the splice functions are more problematic since they are the +ones that actually use TemplateState's monad parameter. + +You will also notice that the Heist snaplet includes a HasHeist type class. +Normally to use snaplets, you must "call" them using with or withTop, +passing the lens to the desired snaplet. This is useful because it allows you +to have multiple instances of the same snaplet. However, there may be times +when you know you will only ever need a single instance of a particular +snaplet and you'd like to avoid the need to manually change the context every +time. + +This is where type classes are useful. The HasHeist type class essentially +defines some global compile-time state associating a particular lens to be +used for calls to Heist within a particular type. To use Heist, just define a +HasHeist instance for your application or snaplet type and all the Heist API +functions will work without needing with. Your HasHeist instance will +look something like this: + + instance HasHeist App where + heistLens = subSnaplet heist + +The call to subSnaplet is required because HasHeist needs a `Lens +(Snaplet v) (Snaplet (Heist b))` instead of the lens `Lens v (Snaplet (Heist +b))` that you willll get from mkLabels. + diff --git a/haddock.sh b/haddock.sh new file mode 100644 --- /dev/null +++ b/haddock.sh @@ -0,0 +1,10 @@ +#!/bin/sh + +set -x + +HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html --css=extra/haddock.css' + +cabal haddock $HADDOCK_OPTS --hyperlink-source $@ + +cp extra/logo.gif dist/doc/html/snap/haskell_icon.gif +cp extra/hscolour.css dist/doc/html/snap/src/ diff --git a/project_template/barebones/.ghci b/project_template/barebones/.ghci deleted file mode 100644 --- a/project_template/barebones/.ghci +++ /dev/null @@ -1,4 +0,0 @@ -:set -isrc -:set -hide-package MonadCatchIO-mtl -:set -hide-package monads-fd -:set -XOverloadedStrings diff --git a/project_template/barebones/foo.cabal b/project_template/barebones/foo.cabal deleted file mode 100644 --- a/project_template/barebones/foo.cabal +++ /dev/null @@ -1,29 +0,0 @@ -Name: projname -Version: 0.1 -Synopsis: Project Synopsis Here -Description: Project Description Here -License: AllRightsReserved -Author: Author -Maintainer: maintainer@example.com -Stability: Experimental -Category: Web -Build-type: Simple -Cabal-version: >=1.2 - -Executable projname - hs-source-dirs: src - main-is: Main.hs - - Build-depends: - base >= 4 && < 5, - bytestring >= 0.9.1 && < 0.10, - MonadCatchIO-transformers >= 0.2.1 && < 0.4, - mtl >= 2 && < 3, - snap-core == 0.8.*, - snap-server == 0.8.* - - if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-unused-do-bind - else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 diff --git a/project_template/barebones/log/access.log b/project_template/barebones/log/access.log deleted file mode 100644 --- a/project_template/barebones/log/access.log +++ /dev/null diff --git a/project_template/barebones/src/Main.hs b/project_template/barebones/src/Main.hs deleted file mode 100644 --- a/project_template/barebones/src/Main.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Control.Applicative -import Snap.Core -import Snap.Util.FileServe -import Snap.Http.Server - -main :: IO () -main = quickHttpServe site - -site :: Snap () -site = - ifTop (writeBS "hello world") <|> - route [ ("foo", writeBS "bar") - , ("echo/:echoparam", echoHandler) - ] <|> - dir "static" (serveDirectory ".") - -echoHandler :: Snap () -echoHandler = do - param <- getParam "echoparam" - maybe (writeBS "must specify echo/param in URL") - writeBS param diff --git a/project_template/default/.ghci b/project_template/default/.ghci deleted file mode 100644 --- a/project_template/default/.ghci +++ /dev/null @@ -1,4 +0,0 @@ -:set -isrc -:set -hide-package MonadCatchIO-mtl -:set -hide-package monads-fd -:set -XOverloadedStrings diff --git a/project_template/default/foo.cabal b/project_template/default/foo.cabal deleted file mode 100644 --- a/project_template/default/foo.cabal +++ /dev/null @@ -1,51 +0,0 @@ -Name: projname -Version: 0.1 -Synopsis: Project Synopsis Here -Description: Project Description Here -License: AllRightsReserved -Author: Author -Maintainer: maintainer@example.com -Stability: Experimental -Category: Web -Build-type: Simple -Cabal-version: >=1.2 - -Flag development - Description: Whether to build the server in development (interpreted) mode - Default: False - -Executable projname - hs-source-dirs: src - main-is: Main.hs - - Build-depends: - base >= 4 && < 5, - bytestring >= 0.9.1 && < 0.10, - data-lens >= 2.0.1 && < 2.11, - data-lens-template >= 2.1 && < 2.2, - heist >= 0.8 && < 0.9, - MonadCatchIO-transformers >= 0.2.1 && < 0.4, - mtl >= 2 && < 3, - snap == 0.8.*, - snap-core == 0.8.*, - snap-server == 0.8.*, - text >= 0.11 && < 0.12, - time >= 1.1 && < 1.5, - xmlhtml == 0.1.* - - if flag(development) - cpp-options: -DDEVELOPMENT - -- In development mode, speed is already going to suffer, so skip - -- the fancy optimization flags. Additionally, disable all - -- warnings. The hint library doesn't give an option to execute - -- compiled code when there were also warnings, so disabling - -- warnings allows quicker workflow. - ghc-options: -threaded -w - else - if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-orphans -fno-warn-unused-do-bind - else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-orphans - diff --git a/project_template/default/log/access.log b/project_template/default/log/access.log deleted file mode 100644 --- a/project_template/default/log/access.log +++ /dev/null diff --git a/project_template/default/log/error.log b/project_template/default/log/error.log deleted file mode 100644 --- a/project_template/default/log/error.log +++ /dev/null diff --git a/project_template/default/snaplets/heist/templates/echo.tpl b/project_template/default/snaplets/heist/templates/echo.tpl deleted file mode 100644 --- a/project_template/default/snaplets/heist/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/snaplets/heist/templates/index.tpl b/project_template/default/snaplets/heist/templates/index.tpl deleted file mode 100644 --- a/project_template/default/snaplets/heist/templates/index.tpl +++ /dev/null @@ -1,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,30 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------- --- | This module defines our application's state type and an alias for its --- handler monad. --- -module Application where - ------------------------------------------------------------------------------- -import Data.Lens.Template -import Data.Time.Clock -import Snap.Snaplet -import Snap.Snaplet.Heist - ------------------------------------------------------------------------------- -data App = App - { _heist :: Snaplet (Heist App) - , _startTime :: UTCTime - } - -makeLens ''App - -instance HasHeist App where - heistLens = subSnaplet heist - - ------------------------------------------------------------------------------- -type AppHandler = Handler App App - - 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,100 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - -module Main where - ------------------------------------------------------------------------------- -import Control.Exception (SomeException, try) -import qualified Data.Text as T -import Snap.Http.Server -import Snap.Snaplet -import Snap.Core -import System.IO -import Site - -#ifdef DEVELOPMENT -import Snap.Loader.Devel -#else -import Snap.Loader.Prod -#endif - - ------------------------------------------------------------------------------- --- | This is the entry point for this web server application. It supports --- easily switching between interpreting source and running statically compiled --- code. --- --- In either mode, the generated program should be run from the root of the --- project tree. When it is run, it locates its templates, static content, and --- source files in development mode, relative to the current working directory. --- --- When compiled with the development flag, only changes to the libraries, your --- cabal file, or this file should require a recompile to be picked up. --- Everything else is interpreted at runtime. There are a few consequences of --- this. --- --- First, this is much slower. Running the interpreter takes a significant --- chunk of time (a couple tenths of a second on the author's machine, at this --- time), regardless of the simplicity of the loaded code. In order to --- recompile and re-load server state as infrequently as possible, the source --- directories are watched for updates, as are any extra directories specified --- below. --- --- Second, the generated server binary is MUCH larger, since it links in the --- GHC API (via the hint library). --- --- Third, and the reason you would ever want to actually compile with --- development mode, is that it enables a faster development cycle. You can --- simply edit a file, save your changes, and hit reload to see your changes --- reflected immediately. --- --- When this is compiled without the development flag, all the actions are --- statically compiled in. This results in faster execution, a smaller binary --- size, and having to recompile the server for any code change. --- -main :: IO () -main = do - -- Depending on the version of loadSnapTH in scope, this either enables - -- dynamic reloading, or compiles it without. The last argument to - -- loadSnapTH is a list of additional directories to watch for changes to - -- trigger reloads in development mode. It doesn't need to include source - -- directories, those are picked up automatically by the splice. - (conf, site, cleanup) <- $(loadSnapTH [| getConf |] - 'getActions - ["snaplets/heist/templates"]) - - _ <- try $ httpServe conf $ site :: IO (Either SomeException ()) - cleanup - - ------------------------------------------------------------------------------- --- | This action loads the config used by this application. The loaded config --- is returned as the first element of the tuple produced by the loadSnapTH --- Splice. The type is not solidly fixed, though it must be an IO action that --- produces the same type as 'getActions' takes. It also must be an instance of --- Typeable. If the type of this is changed, a full recompile will be needed to --- pick up the change, even in development mode. --- --- This action is only run once, regardless of whether development or --- production mode is in use. -getConf :: IO (Config Snap ()) -getConf = commandLineConfig defaultConfig - - ------------------------------------------------------------------------------- --- | This function generates the the site handler and cleanup action from the --- configuration. In production mode, this action is only run once. In --- development mode, this action is run whenever the application is reloaded. --- --- Development mode also makes sure that the cleanup actions are run --- appropriately before shutdown. The cleanup action returned from loadSnapTH --- should still be used after the server has stopped handling requests, as the --- cleanup actions are only automatically run when a reload is triggered. --- --- This sample doesn't actually use the config passed in, but more --- sophisticated code might. -getActions :: Config Snap () -> IO (Snap (), IO ()) -getActions _ = do - (msgs, site, cleanup) <- runSnaplet app - hPutStrLn stderr $ T.unpack msgs - return (site, cleanup) 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,90 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - ------------------------------------------------------------------------------- --- | This module is where all the routes and handlers are defined for your --- site. The 'app' function is the initializer that combines everything --- together and is exported by this module. --- -module Site - ( app - ) where - ------------------------------------------------------------------------------- -import Control.Applicative -import Control.Monad.Trans -import Control.Monad.State -import Data.ByteString (ByteString) -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Time.Clock -import Snap.Core -import Snap.Snaplet -import Snap.Snaplet.Heist -import Snap.Util.FileServe -import Text.Templating.Heist -import Text.XmlHtml hiding (render) ------------------------------------------------------------------------------- -import Application - - ------------------------------------------------------------------------------- --- | Renders the front page of the sample site. --- --- The 'ifTop' is required to limit this to the top of a route. --- Otherwise, the way the route table is currently set up, this action --- would be given every request. -index :: Handler App App () -index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index" - where - indexSplices = - [ ("start-time", startTimeSplice) - , ("current-time", currentTimeSplice) - ] - - ------------------------------------------------------------------------------- --- | For your convenience, a splice which shows the start time. -startTimeSplice :: Splice AppHandler -startTimeSplice = do - time <- lift $ gets _startTime - return $ [TextNode $ T.pack $ show $ time] - - ------------------------------------------------------------------------------- --- | For your convenience, a splice which shows the current time. -currentTimeSplice :: Splice AppHandler -currentTimeSplice = do - time <- liftIO getCurrentTime - return $ [TextNode $ T.pack $ show $ time] - - ------------------------------------------------------------------------------- --- | Renders the echo page. -echo :: Handler App App () -echo = do - message <- decodedParam "stuff" - heistLocal (bindString "message" (T.decodeUtf8 message)) $ render "echo" - where - decodedParam p = fromMaybe "" <$> getParam p - - ------------------------------------------------------------------------------- --- | The application's routes. -routes :: [(ByteString, Handler App App ())] -routes = [ ("/", index) - , ("/echo/:stuff", echo) - , ("", with heist heistServe) - , ("", serveDirectory "static") - ] - ------------------------------------------------------------------------------- --- | The application initializer. -app :: SnapletInit App App -app = makeSnaplet "app" "An snaplet example application." Nothing $ do - sTime <- liftIO getCurrentTime - h <- nestSnaplet "heist" heist $ heistInit "templates" - addRoutes routes - return $ App h sTime - - diff --git a/project_template/default/static/screen.css b/project_template/default/static/screen.css deleted file mode 100644 --- a/project_template/default/static/screen.css +++ /dev/null @@ -1,26 +0,0 @@ -html { - padding: 0; - margin: 0; - background-color: #ffffff; - font-family: Verdana, Helvetica, sans-serif; -} -body { - padding: 0; - margin: 0; -} -a { - text-decoration: underline; -} -a :hover { - cursor: pointer; - text-decoration: underline; -} -img { - border: none; -} -#content { - padding-left: 1em; -} -#info { - font-size: 60%; -} diff --git a/project_template/tutorial/.ghci b/project_template/tutorial/.ghci deleted file mode 100644 --- a/project_template/tutorial/.ghci +++ /dev/null @@ -1,4 +0,0 @@ -:set -isrc -:set -hide-package MonadCatchIO-mtl -:set -hide-package monads-fd -:set -XOverloadedStrings diff --git a/project_template/tutorial/foo.cabal b/project_template/tutorial/foo.cabal deleted file mode 100644 --- a/project_template/tutorial/foo.cabal +++ /dev/null @@ -1,30 +0,0 @@ -Name: projname -Version: 0.1 -Synopsis: Project Synopsis Here -Description: Project Description Here -License: AllRightsReserved -Author: Author -Maintainer: maintainer@example.com -Stability: Experimental -Category: Web -Build-type: Simple -Cabal-version: >=1.2 - -Executable projname - hs-source-dirs: src - main-is: Tutorial.lhs - - Build-depends: - base >= 4 && < 5, - bytestring >= 0.9.1 && < 0.10, - MonadCatchIO-transformers >= 0.2.1 && < 0.4, - mtl >= 2 && < 3, - snap == 0.8.*, - snap-core == 0.8.*, - snap-server == 0.8.* - - if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-unused-do-bind - else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 diff --git a/project_template/tutorial/log/placeholder b/project_template/tutorial/log/placeholder deleted file mode 100644 --- a/project_template/tutorial/log/placeholder +++ /dev/null @@ -1,1 +0,0 @@ -placeholder diff --git a/project_template/tutorial/src/Part2.lhs b/project_template/tutorial/src/Part2.lhs deleted file mode 100644 --- a/project_template/tutorial/src/Part2.lhs +++ /dev/null @@ -1,14 +0,0 @@ -> {-# LANGUAGE OverloadedStrings #-} -> module Part2 where - -> import Snap.Snaplet - -> data Foo = Foo -> -> data Bar = Bar -> -> fooInit = makeSnaplet "foo" "Foo snaplet" Nothing $ do -> return Foo -> -> barInit h = makeSnaplet "bar" "Bar snaplet" Nothing $ do -> return Bar diff --git a/project_template/tutorial/src/Tutorial.lhs b/project_template/tutorial/src/Tutorial.lhs deleted file mode 100644 --- a/project_template/tutorial/src/Tutorial.lhs +++ /dev/null @@ -1,353 +0,0 @@ -What Are Snaplets? -================== - -A snaplet is a composable web application. Snaplets allow you to build -self-contained pieces of functionality and glue them together to make larger -applications. Here are some of the things provided by the snaplet API: - - - Infrastructure for application state/environment - - - Snaplet initialization, reload, and cleanup - - - Management of filesystem data and automatic snaplet installation - - - Unified config file infrastructure - -One example might be a wiki snaplet. It would be distributed as a haskell -package that would be installed with cabal and would probably include code, -config files, HTML templates, stylesheets, JavaScript, images, etc. The -snaplet's code would provide the necessary API to let your application -interact seamlessly with the wiki functionality. When you run your -application for the first time, all of the wiki snaplet's filesystem resources -will automatically be copied into the appropriate places. Then you will -immediately be able to customize the wiki to fit your needs by editing config -files, providing your own stylesheets, etc. We will discuss this in more -detail later. - -A snaplet can represent anything from backend Haskell infrastructure with no -user facing functionality to a small widget like a chat box that goes in the -corner of a web page to an entire standalone website like a blog or forum. -The possibilities are endless. A snaplet is a web application, and web -applications are snaplets. This means that using snaplets and writing -snaplets are almost the same thing, and it's trivial to drop a whole website -into another one. - -We're really excited about the possibilities available with snaplets. In -fact, Snap already ships with snaplets for sessions, authentication, and -templating (with Heist), This gives you useful functionality out of the box, -and jump starts your own snaplet development by demonstrating some useful -design patterns. So without further ado, let's get started. - -Snaplet Overview -================ - -The heart of the snaplets infrastructure is state management. Most nontrivial -pieces of a web app need some kind of state or environment data. Components -that do not need any kind of state or environment are probably more -appropriate as a standalone library than as a snaplet. - -Before we continue, we must clarify an important point. The Snap web server -processes each request in its own green thread. This means that each request -will receive a separate copy of the state defined by your application and -snaplets, and modifications to that state only affect the local thread that -generates a single response. From now on, when we talk about state this is -what we are talking about. If you need global application state, you have to -use a thread-safe construct such as an MVar or IORef. - -This post is written in literate Haskell, so first we need to get imports out -of the way. - -> {-# LANGUAGE TemplateHaskell #-} -> {-# LANGUAGE OverloadedStrings #-} -> -> module Main where -> -> import Data.IORef -> import qualified Data.ByteString.Char8 as B -> import Data.Maybe -> import Snap -> import Snap.Snaplet.Heist -> import Part2 - -We start our application by defining a data structure to hold the state. This -data structure includes the state of all snaplets (wrapped in a Snaplet) used -by our application as well as any other state we might want. - -> data App = App -> { _heist :: Snaplet (Heist App) -> , _foo :: Snaplet Foo -> , _bar :: Snaplet Bar -> , _companyName :: IORef B.ByteString -> } -> -> makeLenses [''App] - -The field names begin with an underscore because of some more complicated -things going on under the hood. However, all you need to know right now is -that you should prefix things with an underscore and then call `makeLenses`. -This lets you use the names without an underscore in the rest of your -application. - -The next thing we need to do is define an initializer. - -> appInit :: SnapletInit App App -> appInit = makeSnaplet "myapp" "My example application" Nothing $ do -> hs <- nestSnaplet "heist" heist $ heistInit "templates" -> fs <- nestSnaplet "foo" foo $ fooInit -> bs <- nestSnaplet "" bar $ nameSnaplet "newname" $ barInit foo -> addRoutes [ ("/hello", writeText "hello world") -> , ("/fooname", with foo namePage) -> , ("/barname", with bar namePage) -> , ("/company", companyHandler) -> ] -> wrapHandlers (<|> heistServe) -> ref <- liftIO $ newIORef "fooCorp" -> return $ App hs fs bs ref - -For now don't worry about all the details of this code. We'll work through the -individual pieces one at a time. The basic idea here is that to initialize an -application, we first initialize each of the snaplets, add some routes, run a -function wrapping all the routes, and return the resulting state data -structure. This example demonstrates the use of a few of the most common -snaplet functions. - -nestSnaplet ------------ - -All calls to child snaplet initializer functions must be wrapped in a call to -nestSnaplet. The first parameter is a URL path segment that is used to prefix -all routes defined by the snaplet. This lets you ensure that there will be no -problems with duplicate routes defined in different snaplets. If the foo -snaplet defines a route `/foopage`, then in the above example, that page will -be available at `/foo/foopage`. Sometimes though, you might want a snaplet's -routes to be available at the top level. To do that, just pass an empty string -to nestSnaplet as shown above with the bar snaplet. - -In our example above, the bar snaplet does something that needs to know about -the foo snaplet. Maybe foo is a database snaplet and bar wants to store or -read something. In order to make that happen, it needs to have a "handle" to -the snaplet. Our handles are whatever field names we used in the App data -structure minus the initial underscore character. They are automatically -generated by the `makeLenses` function. For now it's sufficient to think of -them as a getter and a setter combined (to use an OO metaphor). - -The second parameter to nestSnaplet is the lens to the snaplet you're nesting. -In order to place a piece into the puzzle, you need to know where it goes. - -nameSnaplet ------------ - -The author of a snaplet defines a default name for the snaplet in the first -argument to the makeSnaplet function. This name is used for the snaplet's -directory in the filesystem. If you don't want to use the default name, you -can override it with the `nameSnaplet` function. Also, if you want to have two -instances of the same snaplet, then you will need to use `nameSnaplet` to give -at least one of them a unique name. - -addRoutes ---------- - -The `addRoutes` function is how an application (or snaplet) defines its -routes. Under the hood the snaplet infrastructure merges all the routes from -all snaplets, prepends prefixes from `nestSnaplet` calls, and passes the list -to Snap's -[route](http://hackage.haskell.org/packages/archive/snap-core/0.5.1.4/doc/html/Snap-Types.html#v:route) -function. - -A route is a tuple of a URL and a handler function that will be called when -the URL is requested. Handler is a wrapper around the Snap monad that handles -the snaplet's infrastructure. During initialization, snaplets use the -`Initializer` monad. During runtime, they use the `Handler` monad. We'll -discuss `Handler` in more detail later. If you're familiar with Snap's old -extension system, you can think of it as roughly equivalent to the Application -monad. It has a `MonadState` instance that lets you access and modify the -current snaplet's state, and a `MonadSnap` instance providing the -request-processing functions defined in Snap.Types. - -wrapHandlers ------------- - -`wrapHandlers` allows you to apply an arbitrary `Handler` transformation to -the top-level handler. This is useful if you want to do some generic -processing at the beginning or end of every request. For instance, a session -snaplet might use it to touch a session activity token before routing happens. -It could also be used to implement custom logging. The example above uses it -to define heistServe (provided by the Heist snaplet) as the default handler to -be tried if no other handler matched. This may seem like an easy way to define -routes, but if you string them all together in this way each handler will be -evaluated sequentially and you'll get O(n) time complexity, whereas routes -defined with `addRoutes` have O(log n) time complexity. Therefore, in a -real-world application you would probably want to have `("", heistServe)` in -the list passed to `addRoutes`. - -with ----- - -The last unfamiliar function in the example is `with`. Here it accompanies a -call to the function `namePage`. `namePage` is a simple example handler and -looks like this. - -> namePage :: Handler b v () -> namePage = do -> mname <- getSnapletName -> writeText $ fromMaybe "This shouldn't happen" mname - -This function is a generic handler that gets the name of the current snaplet -and writes it into the response with the `writeText` function defined by the -snap-core project. The type variables 'b' and 'v' indicate that this function -will work in any snaplet with any base application. The 'with' function is -used to run `namePage` in the context of the snaplets foo and bar for the -corresponding routes. - -Site Reloading --------------- - -Snaplet Initializers serve dual purpose as both initializers and reloaders. -Reloads are triggered by a special handler that is bound to the -`/admin/reload` route. This handler re-runs the site initializer and if it is -successful, loads the newly generated in-memory state. To prevent denial of -service attacks, the reload route is only accessible from localhost. - -If there are any errors during reload, you would naturally want to see them in -the HTTP response returned by the server. However, when these same -initializers are run when you first start your app, you will want to see -status messages printed to the console. To make this possible we provide the -`printInfo` function. You should use it to output any informational messages -generated by your initializers. If you print directly to standard output or -standard error, then those messages will not be available in your browser when -you reload the site. - -Working with state ------------------- - -`Handler b v` has a `MonadState v` instance. This means that you can access -all your snaplet state through the get, put, gets, and modify functions that -are probably familiar from the state monad. In our example application we -demonstrate this with `companyHandler`. - -> companyHandler :: Handler App App () -> companyHandler = method GET getter <|> method POST setter -> where -> getter = do -> nameRef <- gets _companyName -> name <- liftIO $ readIORef nameRef -> writeBS name -> setter = do -> mname <- getParam "name" -> nameRef <- gets _companyName -> liftIO $ maybe (return ()) (writeIORef nameRef) mname -> getter - -If you set a GET request to `/company`, you'll get the string "fooCorp" back. -If you send a POST request, it will set the IORef held in the `_companyName` -field in the `App` data structure to the value of the `name` field. Then it -calls the getter to return that value back to you so you can see it was -actually changed. Again, remember that this change only persists across -requests because we used an IORef. If `_companyName` was just a plain string -and we had used modify, the changed result would only be visible in the rest -of the processing for that request. - -The Heist Snaplet -================= - -The astute reader might ask why there is no `with heist` in front of the call -to `heistServe`. And indeed, that would normally be the case. But we decided -that an application will never need more than one instance of a Heist snaplet. -So we provided a type class called `HasHeist` that allows an application to -define the global reference to its Heist snaplet by writing a `HasHeist` -instance. In this example we define the instance as follows: - -> instance HasHeist App where heistLens = subSnaplet heist - -Now all we need is a simple main function to serve our application. - -> main :: IO () -> main = serveSnaplet defaultConfig appInit - -This completes a full working application. We did leave out a little dummy -code for the Foo and Bar snaplets. This code is included in Part2.hs. For -more information look in our [API -documentation](http://hackage.haskell.org/packages/archive/snap/0.6.0.2/doc/html/Snap-Snaplet.html). -No really, that wasn't a joke. The API docs are written as prose. It is -written to be very easy to read, while having the benefit of including all the -actual type signatures. - -Filesystem Data and Automatic Installation -========================================== - -Some snaplets will have data stored in the filesystem that should be installed -into the directory of any project that uses it. Here's an example of what a -snaplet filesystem layout might look like: - - foosnaplet/ - |-- *snaplet.cfg* - |-- db.cfg - |-- public/ - |-- stylesheets/ - |-- images/ - |-- js/ - |-- *snaplets/* - |-- *heist/* - |-- templates/ - |-- subsnaplet1/ - |-- subsnaplet2/ - -Only the starred items are actually enforced by current code, but we want to -establish the others as a convention. The file snaplet.cfg is automatically -read by the snaplet infrastructure. It is available to you via the -`getSnapletUserConfig` function. Config files use the format defined by Bryan -O'Sullivan's excellent [configurator -package](http://hackage.haskell.org/package/configurator). In this example, -the user has chosen to put db config items in a separate file and use -configurator's import functionality to include it in snaplet.cfg. If -foosnaplet uses `nestSnaplet` or `embedSnaplet` to include any other snaplets, -then filesystem data defined by those snaplets will be included in -subdirectories under the `snaplets/` directory. - -So how do you tell the snaplet infrastructure that your snaplet has filesystem -data that should be installed? Look at the definition of appInit above. The -third argument to the makeSnaplet function is where we specify the filesystem -directory that should be installed. That argument has the type `Maybe (IO -FilePath)`. In this case we used `Nothing` because our simple example doesn't -have any filesystem data. As an example, let's say you are creating a snaplet -called killerapp that will be distributed as a hackage project called -snaplet-killerapp. Your project directory structure will look something like -this: - - snaplet-killerapp/ - |-- resources/ - |-- snaplet-killerapp.cabal - |-- src/ - -All of the files and directories listed above under foosnaplet/ will be in -resources/. Somewhere in the code you will define an initializer for the -snaplet that will look like this: - - killerInit = makeSnaplet "killerapp" "42" (Just dataDir) $ do - -The primary function of Cabal is to install code. But it has the ability to -install data files and provides a function called `getDataDir` for retrieving -the location of these files. Since it returns a different result depending on -what machine you're using, the third argument to `makeSnaplet` has to be `Maybe -(IO FilePath)` instead of the more natural pure version. To make things more -organized, we use the convention of putting all your snaplet's data files in a -subdirectory called resources. So we need to create a small function that -appends `/resources` to the result of `getDataDir`. - - import Paths_snaplet_killerapp - dataDir = liftM (++"/resources") getDataDir - -If our project is named snaplet-killerapp, the `getDataDir` function is -defined in the module Paths_snaplet_killerapp, which we have to import. To -make everything work, you have to tell Cabal about your data files by -including a section like the following in snaplet-killerapp.cabal: - - data-files: - resources/snaplet.cfg, - resources/public/stylesheets/style.css, - resources/snaplets/heist/templates/page.tpl - -Now whenever your snaplet is used, its filesystem data will be automagically -copied into the local project that is using it, whenever the application is -run and it sees that the files don't already exist. - 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: Ozgun Ataman, Doug Beardsley, Gregory Collins, Carl Howells, Chris Smith +author: Ozgun Ataman, Doug Beardsley, + Gregory Collins, Carl Howells, Chris Smith maintainer: snap@snapframework.com build-type: Simple -cabal-version: >= 1.8 homepage: http://snapframework.com/ +bug-reports: https://github.com/snapframework/snap/issues category: Web, Snap +tested-with: + GHC == 8.8.4 + GHC == 8.10.7 + GHC == 9.0.2 + GHC == 9.2.8 + GHC == 9.4.5 + GHC == 9.6.2 + extra-source-files: + .ghci, CONTRIBUTORS, LICENSE, README.md, README.SNAP.md, - project_template/barebones/.ghci, - project_template/barebones/foo.cabal, - project_template/barebones/log/access.log, - project_template/barebones/src/Main.hs, - project_template/default/.ghci, - project_template/default/foo.cabal, - project_template/default/log/access.log, - project_template/default/log/error.log, - project_template/default/static/screen.css, - project_template/default/snaplets/heist/templates/echo.tpl, - project_template/default/snaplets/heist/templates/index.tpl, - project_template/default/src/Application.hs, - project_template/default/src/Main.hs, - project_template/default/src/Site.hs, - project_template/tutorial/.ghci, - project_template/tutorial/foo.cabal, - project_template/tutorial/log/placeholder, - project_template/tutorial/src/Part2.lhs, - project_template/tutorial/src/Tutorial.lhs, + changelog.md, + design.md, extra/hscolour.css, extra/haddock.css, extra/logo.gif, - test/snap-testsuite.cabal, - test/runTestsAndCoverage.sh, - test/suite/TestSuite.hs, - test/suite/NestTest.hs, - test/suite/Snap/TestCommon.hs, - test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs, - test/suite/Snap/Snaplet/Internal/RST/Tests.hs, - test/suite/Snap/Snaplet/Internal/Tests.hs, - test/suite/Snap/Snaplet/Internal/LensT/Tests.hs, - test/suite/Blackbox/Types.hs, - test/suite/Blackbox/FooSnaplet.hs, - test/suite/Blackbox/BarSnaplet.hs, - test/suite/Blackbox/Common.hs, - test/suite/Blackbox/EmbeddedSnaplet.hs, - test/suite/Blackbox/Tests.hs, - test/suite/Blackbox/App.hs, - test/suite/SafeCWD.hs, - test/suite/AppMain.hs, - test/non-cabal-appdir/db.cfg, - test/non-cabal-appdir/bad.tpl, - test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl, - test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl, - test/non-cabal-appdir/snaplets/baz/snaplet.cfg, - test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl, - test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl, - test/non-cabal-appdir/snaplets/heist/templates/index.tpl, - test/non-cabal-appdir/snaplets/heist/templates/session.tpl, - test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl, - test/non-cabal-appdir/snaplets/heist/templates/page.tpl, - test/non-cabal-appdir/good.tpl, - test/non-cabal-appdir/log/placeholder, - test/non-cabal-appdir/snaplet.cfg, - test/foosnaplet/templates/foopage.tpl, - test/foosnaplet/snaplet.cfg + haddock.sh, + runTestsAndCoverage.sh, + test/bad.tpl, + test/db.cfg, + test/devel.cfg, + test/good.tpl, + test/snaplets/baz/devel.cfg, + test/snaplets/baz/templates/bazconfig.tpl, + test/snaplets/baz/templates/bazpage.tpl, + test/snaplets/embedded/extra-templates/extra.tpl, + test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl, + test/snaplets/foosnaplet/devel.cfg, + test/snaplets/foosnaplet/templates/foopage.tpl, + test/snaplets/heist/templates/_foopage.tpl, + test/snaplets/heist/templates/extraTemplates/barpage.tpl, + test/snaplets/heist/templates/foopage.tpl, + test/snaplets/heist/templates/index.tpl, + test/snaplets/heist/templates/page.tpl, + test/snaplets/heist/templates/session.tpl, + test/snaplets/heist/templates/splicepage.tpl, + test/snaplets/heist/templates/userpage.tpl -Flag hint - Description: Support dynamic project reloading via hint - Default: False +common universal + default-language: Haskell2010 + build-depends: + , base >= 4.5 && < 5 + + if !impl(ghc >= 8.0) + build-depends: + , semigroups >= 0.16 && < 0.19 + , fail >= 4.9 && < 4.10 + + default-extensions: + BangPatterns + CPP + DeriveDataTypeable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + MultiParamTypeClasses + NoMonomorphismRestriction + OverloadedStrings + PackageImports + Rank2Types + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TypeFamilies + TypeOperators + TypeSynonymInstances + Library + import: universal hs-source-dirs: src exposed-modules: - Snap, - Snap.Loader.Prod, - Snap.Loader.Devel, - Snap.Snaplet, - Snap.Snaplet.Heist, - Snap.Snaplet.Auth, - Snap.Snaplet.Auth.Backends.JsonFile, - Snap.Snaplet.Session, - Snap.Snaplet.Session.Common, + Snap + Snap.Snaplet + Snap.Snaplet.Heist + Snap.Snaplet.HeistNoClass + Snap.Snaplet.Heist.Compiled + Snap.Snaplet.Heist.Generic + Snap.Snaplet.Heist.Interpreted + Snap.Snaplet.Auth + Snap.Snaplet.Auth.Backends.JsonFile + Snap.Snaplet.Config + Snap.Snaplet.Session + Snap.Snaplet.Session.Common + Snap.Snaplet.Session.SessionManager Snap.Snaplet.Session.Backends.CookieSession + Snap.Snaplet.Test other-modules: - Control.Access.RoleBased.Checker, - Control.Access.RoleBased.Role, - Control.Access.RoleBased.Types, - Control.Access.RoleBased.Internal.Role, - Control.Access.RoleBased.Internal.RoleMap, - Control.Access.RoleBased.Internal.Rule, - Control.Access.RoleBased.Internal.Types, - Snap.Snaplet.Auth.AuthManager, - Snap.Snaplet.Auth.Types, - Snap.Snaplet.Auth.Handlers, - Snap.Snaplet.Auth.SpliceHelpers, - Snap.Snaplet.HeistNoClass, - Snap.Snaplet.Internal.Initializer, - Snap.Snaplet.Internal.LensT, - Snap.Snaplet.Internal.Lensed, - Snap.Snaplet.Internal.RST, + Paths_snap + Snap.Snaplet.Auth.AuthManager + Snap.Snaplet.Auth.Types + Snap.Snaplet.Auth.Handlers + Snap.Snaplet.Auth.SpliceHelpers + Snap.Snaplet.Heist.Internal + Snap.Snaplet.Internal.Initializer + Snap.Snaplet.Internal.LensT + Snap.Snaplet.Internal.Lensed + Snap.Snaplet.Internal.RST Snap.Snaplet.Internal.Types - Snap.Snaplet.Session.SecureCookie, - Snap.Snaplet.Session.SessionManager - - if flag(hint) - other-modules: - Snap.Loader.Devel.Evaluator, - Snap.Loader.Devel.Signal, - Snap.Loader.Devel.TreeWatcher - - cpp-options: -DHINT_ENABLED - - build-depends: - hint >= 0.3.3.1 && < 0.4, - old-time >= 1.0 && < 1.2 - - if !os(windows) - build-depends: - unix >= 2.2.0.0 && < 2.6 + Snap.Snaplet.Session.SecureCookie build-depends: - MonadCatchIO-transformers >= 0.2 && < 0.4, - aeson >= 0.6 && < 0.7, - attoparsec >= 0.10 && < 0.11, - base >= 4 && < 5, - bytestring >= 0.9.1 && < 0.10, - cereal >= 0.3 && < 0.4, - clientsession >= 0.7.3.6 && <0.8, - configurator >= 0.1 && < 0.3, - containers >= 0.3 && < 0.5, - directory >= 1.0 && < 1.2, - directory-tree >= 0.10 && < 0.11, - data-lens >= 2.0.1 && < 2.11, - data-lens-template >= 2.1 && < 2.2, - filepath >= 1.1 && < 1.4, - hashable >= 1.1 && < 1.2, - heist >= 0.7 && < 0.9, - logict >= 0.4.2 && < 0.6, - mtl > 2.0 && < 2.2, - mwc-random >= 0.8 && < 0.13, - pwstore-fast >= 2.2 && < 2.3, - snap-core >= 0.8.1 && < 0.9, - snap-server >= 0.8.1 && < 0.9, - stm >= 2.2 && < 2.4, - syb >= 0.1 && < 0.4, - template-haskell >= 2.2 && < 2.8, - text >= 0.11 && < 0.12, - time >= 1.1 && < 1.5, - transformers >= 0.2 && < 0.4, + aeson >= 0.6 && < 2.3, + attoparsec >= 0.10 && < 0.15, + attoparsec-aeson >= 2.1.0.0 && < 3.0, + bytestring >= 0.9.1 && < 0.13, + cereal >= 0.3 && < 0.6, + clientsession >= 0.8 && < 0.10, + configurator >= 0.1 && < 0.4, + containers >= 0.2 && < 0.8, + directory >= 1.1 && < 1.4, + directory-tree >= 0.11 && < 0.13, + dlist >= 0.5 && < 1.1, + filepath >= 1.3 && < 1.5, + -- hashable is broken from 1.2.0.0 through 1.2.0.5 + -- snap does work with hashable 1.1.*, but some have complained that + -- the version disjunction causes problems with dependency resolution. + hashable >= 1.2.0.6 && < 1.5, + heist >= 1.1 && < 1.2, + lens >= 3.7.6 && < 5.3, + lifted-base >= 0.2 && < 0.3, + map-syntax >= 0.2 && < 0.4, + monad-control >= 0.3 && < 1.1, + mtl >= 2.0 && < 2.4, + mwc-random >= 0.8 && < 0.16, + pwstore-fast >= 2.2 && < 2.5, + snap-core >= 1.0 && < 1.1, + snap-server >= 1.0 && < 1.2, + stm >= 2.2 && < 2.6, + text >= 1.1.1.0 && < 2.2, + time >= 1.1 && < 1.14, + transformers >= 0.2 && < 0.7, + transformers-base >= 0.4 && < 0.5, unordered-containers >= 0.1.4 && < 0.3, - utf8-string >= 0.3 && < 0.4, - vector >= 0.7.1 && < 0.10, - vector-algorithms >= 0.4 && < 0.6, - xmlhtml >= 0.1 && < 0.2 - - extensions: - BangPatterns, - CPP, - DeriveDataTypeable, - ExistentialQuantification, - FlexibleContexts, - FlexibleInstances, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses, - NoMonomorphismRestriction, - OverloadedStrings, - PackageImports, - Rank2Types, - ScopedTypeVariables, - TemplateHaskell, - TypeFamilies, - TypeOperators, - TypeSynonymInstances + xmlhtml >= 0.1 && < 0.3 if impl(ghc >= 6.12.0) - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -fno-warn-unused-do-bind else - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -Executable snap - hs-source-dirs: src - main-is: Snap/Starter.hs - - other-modules: Snap.StarterTH +Test-suite testsuite + import: universal + hs-source-dirs: src test/suite + type: exitcode-stdio-1.0 + main-is: TestSuite.hs - build-depends: - base >= 4 && < 5, - bytestring >= 0.9.1 && < 0.10, - containers >= 0.3 && < 0.5, - directory >= 1.0 && < 1.2, - directory-tree >= 0.10 && < 0.11, - filepath >= 1.1 && < 1.4, - old-time >= 1.0 && < 1.2, - snap-server >= 0.8 && < 0.9, - template-haskell >= 2.2 && < 2.8, - text >= 0.11 && < 0.12 + autogen-modules: + Paths_snap - ghc-prof-options: -prof -auto-all + other-modules: + Blackbox.Tests + Paths_snap + SafeCWD + Snap + Snap.Snaplet + Snap.Snaplet.Auth + Snap.Snaplet.Auth.AuthManager + Snap.Snaplet.Auth.Backends.JsonFile + Snap.Snaplet.Auth.Handlers + Snap.Snaplet.Auth.Handlers.Tests + Snap.Snaplet.Auth.SpliceHelpers + Snap.Snaplet.Auth.SpliceTests + Snap.Snaplet.Auth.Tests + Snap.Snaplet.Auth.Types + Snap.Snaplet.Auth.Types.Tests + Snap.Snaplet.Test.Common.App + Snap.Snaplet.Test.Common.BarSnaplet + Snap.Snaplet.Test.Common.EmbeddedSnaplet + Snap.Snaplet.Test.Common.FooSnaplet + Snap.Snaplet.Test.Common.Handlers + Snap.Snaplet.Test.Common.Types + Snap.Snaplet.Config + Snap.Snaplet.Config.Tests + Snap.Snaplet.Heist + Snap.Snaplet.Heist.Compiled + Snap.Snaplet.Heist.Generic + Snap.Snaplet.Heist.Internal + Snap.Snaplet.Heist.Interpreted + Snap.Snaplet.Heist.Tests + Snap.Snaplet.HeistNoClass + Snap.Snaplet.Internal.Initializer + Snap.Snaplet.Internal.LensT + Snap.Snaplet.Internal.LensT.Tests + Snap.Snaplet.Internal.Lensed + Snap.Snaplet.Internal.Lensed.Tests + Snap.Snaplet.Internal.RST + Snap.Snaplet.Internal.RST.Tests + Snap.Snaplet.Internal.Tests + Snap.Snaplet.Internal.Types + Snap.Snaplet.Session + Snap.Snaplet.Session.Backends.CookieSession + Snap.Snaplet.Session.Common + Snap.Snaplet.Session.SecureCookie + Snap.Snaplet.Session.SessionManager + Snap.Snaplet.Test + Snap.Snaplet.Test.Tests + Snap.TestCommon - if impl(ghc >= 6.12.0) - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-orphans -fno-warn-unused-do-bind - else - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 - -fno-warn-orphans + build-depends: + aeson, + async >= 2.0.1.5 && < 2.3, + attoparsec, + attoparsec-aeson, + bytestring, + cereal, + clientsession, + configurator, + containers, + deepseq, + directory, + directory-tree, + dlist, + filepath, + hashable, + heist, + http-streams >= 0.7.1.1 && < 0.9, + HUnit >= 1.2.5.2 && < 1.7, + lens, + lifted-base, + map-syntax, + monad-control, + mtl, + mwc-random, + pwstore-fast, + QuickCheck >= 2.4.2 && < 2.15, + smallcheck >= 1.1.1 && < 1.3, + snap-core, + snap-server, + snap, + stm, + syb, + test-framework >= 0.8.0.3 && < 0.9, + test-framework-hunit >= 0.3.0.1 && < 0.4, + test-framework-quickcheck2 >= 0.3.0.3 && < 0.4, + test-framework-smallcheck >= 0.2 && < 0.3, + text, + time, + transformers, + transformers-base, + unordered-containers, + xmlhtml source-repository head type: git diff --git a/src/Control/Access/RoleBased/Checker.hs b/src/Control/Access/RoleBased/Checker.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Checker.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Control.Access.RoleBased.Checker where - ------------------------------------------------------------------------------- -import Control.Monad -import Control.Monad.Logic -import Control.Monad.Reader -import Control.Monad.State.Lazy -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as M -import Data.Maybe (fromMaybe, isJust) -import Data.Text (Text) ------------------------------------------------------------------------------- -import Control.Access.RoleBased.Internal.RoleMap (RoleMap) -import qualified Control.Access.RoleBased.Internal.RoleMap as RM -import Control.Access.RoleBased.Internal.Types -import Control.Access.RoleBased.Role - - ------------------------------------------------------------------------------- -type RoleBuilder a = StateT RoleMap RoleMonad a - - ------------------------------------------------------------------------------- -applyRule :: Role -> Rule -> [Role] -applyRule r (Rule _ f) = f r - - ------------------------------------------------------------------------------- -applyRuleSet :: Role -> RuleSet -> [Role] -applyRuleSet r (RuleSet m) = f r - where - f = fromMaybe (const []) $ M.lookup (_roleName r) m - - ------------------------------------------------------------------------------- -checkUnseen :: Role -> RoleBuilder () -checkUnseen role = do - m <- get - if isJust $ RM.lookup role m then mzero else return () - - ------------------------------------------------------------------------------- -checkSeen :: Role -> RoleBuilder () -checkSeen = lnot . checkUnseen - - ------------------------------------------------------------------------------- -markSeen :: Role -> RoleBuilder () -markSeen role = modify $ RM.insert role - - ------------------------------------------------------------------------------- -isum :: (MonadLogic m, MonadPlus m) => [m a] -> m a -isum l = case l of - [] -> mzero - (x:xs) -> x `interleave` isum xs - - ------------------------------------------------------------------------------- --- | Given a set of roles to check, and a set of implication rules describing --- how a given role inherits from other roles, this function produces a stream --- of expanded Roles. If a Role is seen twice, expandRoles mzeros. -expandRoles :: [Rule] -> [Role] -> RoleMonad Role -expandRoles rules roles0 = evalStateT (go roles0) RM.empty - where - ruleSet = rulesToSet rules - - go roles = isum $ map expandOne roles - - expandOne role = do - checkUnseen role - markSeen role - return role `interleave` go newRoles - - where - newRoles = applyRuleSet role ruleSet - - ------------------------------------------------------------------------------- -hasRole :: Role -> RuleChecker () -hasRole r = RuleChecker $ do - ch <- ask - once $ go ch - where - go gen = do - r' <- lift gen - if r `matches` r' then return () else mzero - - ------------------------------------------------------------------------------- -missingRole :: Role -> RuleChecker () -missingRole = lnot . hasRole - - ------------------------------------------------------------------------------- -hasAllRoles :: [Role] -> RuleChecker () -hasAllRoles rs = RuleChecker $ do - ch <- ask - lift $ once $ go ch $ RM.fromList rs - where - go gen !st = do - mr <- msplit gen - maybe mzero - (\(r,gen') -> let st' = RM.delete r st - in if RM.null st' - then return () - else go gen' st') - mr - - ------------------------------------------------------------------------------- -hasAnyRoles :: [Role] -> RuleChecker () -hasAnyRoles rs = RuleChecker $ do - ch <- ask - lift $ once $ go ch - where - st = RM.fromList rs - go gen = do - mr <- msplit gen - maybe mzero - (\(r,gen') -> if isJust $ RM.lookup r st - then return () - else go gen') - mr - - ------------------------------------------------------------------------------- -runRuleChecker :: [Rule] - -> [Role] - -> RuleChecker a - -> Bool -runRuleChecker rules roles (RuleChecker f) = - case outs of - [] -> False - _ -> True - where - (RoleMonad st) = runReaderT f $ expandRoles rules roles - outs = observeMany 1 st - - ------------------------------------------------------------------------------- -mkRule :: Text -> (Role -> [Role]) -> Rule -mkRule = Rule - - ------------------------------------------------------------------------------- -implies :: Role -> [Role] -> Rule -implies src dest = Rule (_roleName src) - (\role -> if role `matches` src then dest else []) - - ------------------------------------------------------------------------------- -impliesWith :: Role -> (HashMap Text RoleValue -> [Role]) -> Rule -impliesWith src f = Rule (_roleName src) - (\role -> if src `matches` role - then f $ _roleData role - else []) - - ------------------------------------------------------------------------------- --- Testing code follows: TODO: move into test suite - - -testRules :: [Rule] -testRules = [ "user" `implies` ["guest", "can_post"] - , "superuser" `implies` [ "user" - , "can_moderate" - , "can_administrate"] - , "superuser" `implies` [ addRoleData "arg" "*" "with_arg" ] - , "with_arg" `impliesWith` \dat -> - maybe [] (\arg -> [addRoleData "arg" arg "dependent_arg"]) $ - M.lookup "arg" dat - , "superuser" `implies` [ addRoleData "arg1" "a" $ - addRoleData "arg2" "b" "multi_args" ] - ] - -tX :: RuleChecker () -> Bool -tX f = runRuleChecker testRules ["superuser"] f - -t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17 :: Bool -t1 = tX $ hasAnyRoles ["guest","userz"] - -t2 = tX $ hasAllRoles ["guest","userz"] - -t3 = tX $ hasAllRoles ["guest","user"] - -t4 = tX $ hasRole "can_administrate" - -t5 = tX $ hasRole "lkfdhjkjfhds" - -t6 = tX $ do - hasRole "guest" - hasRole "superuser" - -t7 = tX $ do - hasRole "zzzzz" - hasRole "superuser" - -t8 = tX $ hasRole $ addRoleData "arg" "*" "dependent_arg" - -t9 = tX $ hasRole "multi_args" - -t10 = tX $ hasRole $ addRoleData "arg2" "b" "multi_args" - -t11 = tX $ hasRole $ addRoleData "arg2" "z" "multi_args" - -t12 = tX $ hasAllRoles [addRoleData "arg2" "b" "multi_args"] - -t13 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args" - , addRoleData "arg2" "b" "multi_args" ] - -t14 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args" - , addRoleData "arg2" "aaa" "multi_args" ] - -t15 = tX $ missingRole "jflsdkjf" - -t16 = tX $ do - missingRole "fdjlksjlf" - hasRole "multi_args" - -t17 = tX $ missingRole "multi_args" diff --git a/src/Control/Access/RoleBased/Internal/Role.hs b/src/Control/Access/RoleBased/Internal/Role.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Internal/Role.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Control.Access.RoleBased.Internal.Role where - ------------------------------------------------------------------------------- -import Control.Monad.ST -import Data.Hashable -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as M -import Data.String -import Data.Text (Text) -import qualified Data.Vector as V -import qualified Data.Vector.Algorithms.Merge as VA - - ------------------------------------------------------------------------------- -data RoleValue = RoleBool Bool - | RoleText Text - | RoleInt Int - | RoleDouble Double - deriving (Ord, Eq, Show) - - ------------------------------------------------------------------------------- -instance IsString RoleValue where - fromString = RoleText . fromString - - ------------------------------------------------------------------------------- -instance Hashable RoleValue where - hashWithSalt salt (RoleBool e) = hashWithSalt salt e `combine` 7 - hashWithSalt salt (RoleText t) = hashWithSalt salt t `combine` 196613 - hashWithSalt salt (RoleInt i) = hashWithSalt salt i `combine` 12582917 - hashWithSalt salt (RoleDouble d) = - hashWithSalt salt d `combine` 1610612741 - - ------------------------------------------------------------------------------- -data Role = Role { - _roleName :: Text - , _roleData :: HashMap Text RoleValue - } - deriving (Eq, Show) - - ------------------------------------------------------------------------------- -instance IsString Role where - fromString s = Role (fromString s) M.empty - - ------------------------------------------------------------------------------- -toSortedList :: (Ord k, Ord v) => HashMap k v -> [(k,v)] -toSortedList m = runST $ do - v <- V.unsafeThaw $ V.fromList $ M.toList m - VA.sort v - v' <- V.unsafeFreeze v - return $ V.toList v' - - ------------------------------------------------------------------------------- -instance Hashable Role where - hashWithSalt salt (Role nm dat) = - h $ hashWithSalt salt nm - where - h s = hashWithSalt s $ toSortedList dat - - ------------------------------------------------------------------------------- -data RoleValueMeta = RoleBoolMeta - | RoleTextMeta - | RoleEnumMeta [Text] - | RoleIntMeta - | RoleDoubleMeta - - ------------------------------------------------------------------------------- -data RoleDataDefinition = RoleDataDefinition { - _roleDataName :: Text - , _roleValueMeta :: RoleValueMeta - , _roleDataDescription :: Text - } - - ------------------------------------------------------------------------------- -data RoleMetadata = RoleMetadata { - _roleMetadataName :: Text - , _roleDescription :: Text - , _roleDataDefs :: [RoleDataDefinition] - } diff --git a/src/Control/Access/RoleBased/Internal/RoleMap.hs b/src/Control/Access/RoleBased/Internal/RoleMap.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Internal/RoleMap.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Control.Access.RoleBased.Internal.RoleMap where - ------------------------------------------------------------------------------- -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as M -import Data.HashSet (HashSet) -import qualified Data.HashSet as S -import Data.List (find, foldl') -import Data.Text (Text) ------------------------------------------------------------------------------- -import Control.Access.RoleBased.Role -import Control.Access.RoleBased.Internal.Types - - ------------------------------------------------------------------------------- -newtype RoleMap = RoleMap (HashMap Text (HashSet Role)) - - ------------------------------------------------------------------------------- -fromList :: [Role] -> RoleMap -fromList = RoleMap . foldl' ins M.empty - where - ins m role = - M.insertWith S.union (_roleName role) (S.singleton role) m - - ------------------------------------------------------------------------------- -lookup :: Role -> RoleMap -> Maybe Role -lookup role (RoleMap m) = find (`matches` role) l - where - l = maybe [] S.toList $ M.lookup (_roleName role) m - - ------------------------------------------------------------------------------- -delete :: Role -> RoleMap -> RoleMap -delete role (RoleMap m) = RoleMap $ maybe m upd $ M.lookup rNm m - where - rNm = _roleName role - upd s = maybe m - (\r -> let s' = S.delete r s - in if S.null s' - then M.delete rNm m - else M.insert rNm s' m) - (find (`matches` role) $ S.toList s) - - ------------------------------------------------------------------------------- -insert :: Role -> RoleMap -> RoleMap -insert role (RoleMap m) = - RoleMap $ M.insertWith S.union (_roleName role) (S.singleton role) m - - ------------------------------------------------------------------------------- -empty :: RoleMap -empty = RoleMap M.empty - - ------------------------------------------------------------------------------- -null :: RoleMap -> Bool -null (RoleMap m) = M.null m diff --git a/src/Control/Access/RoleBased/Internal/Rule.hs b/src/Control/Access/RoleBased/Internal/Rule.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Internal/Rule.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Control.Access.RoleBased.Internal.Rule where - ------------------------------------------------------------------------------- -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as M -import Data.List (foldl') -import Data.Monoid -import Data.Text (Text) ------------------------------------------------------------------------------- -import Control.Access.RoleBased.Internal.Role - - ------------------------------------------------------------------------------- -data Rule = Rule Text (Role -> [Role]) - - ------------------------------------------------------------------------------- -newtype RuleSet = RuleSet (HashMap Text (Role -> [Role])) - - ------------------------------------------------------------------------------- -instance Monoid RuleSet where - mempty = RuleSet M.empty - (RuleSet m1) `mappend` (RuleSet m2) = RuleSet $ M.foldlWithKey' ins m2 m1 - where - combine f1 f2 r = f1 r ++ f2 r - ins m k v = M.insertWith combine k v m - - ------------------------------------------------------------------------------- -ruleToSet :: Rule -> RuleSet -ruleToSet (Rule nm f) = RuleSet $ M.singleton nm f - - ------------------------------------------------------------------------------- -rulesToSet :: [Rule] -> RuleSet -rulesToSet = foldl' mappend (RuleSet M.empty) . map ruleToSet diff --git a/src/Control/Access/RoleBased/Internal/Types.hs b/src/Control/Access/RoleBased/Internal/Types.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Internal/Types.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Control.Access.RoleBased.Internal.Types - ( module Control.Access.RoleBased.Internal.Role - , module Control.Access.RoleBased.Internal.Rule - , RoleMonad(..) - , RuleChecker(..) - ) where - ------------------------------------------------------------------------------- -import Control.Applicative -import Control.Monad.Reader -import Control.Monad.Logic ------------------------------------------------------------------------------- -import Control.Access.RoleBased.Internal.Role -import Control.Access.RoleBased.Internal.Rule - - ------------------------------------------------------------------------------- --- TODO: should the monads be transformers here? If they were, you could check --- more complex predicates here - - ------------------------------------------------------------------------------- -newtype RoleMonad a = RoleMonad { _unRC :: Logic a } - deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic) - - ------------------------------------------------------------------------------- -newtype RuleChecker a = RuleChecker (ReaderT (RoleMonad Role) RoleMonad a) - deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic) - diff --git a/src/Control/Access/RoleBased/Role.hs b/src/Control/Access/RoleBased/Role.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Role.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Control.Access.RoleBased.Role where - ------------------------------------------------------------------------------- -import qualified Data.HashMap.Strict as M -import Control.Access.RoleBased.Internal.Types -import Data.Text (Text) - - ------------------------------------------------------------------------------- -matches :: Role -> Role -> Bool -matches (Role a1 d1) (Role a2 d2) = - a1 == a2 && dmatch (toSortedList d1) (toSortedList d2) - where - dmatch [] _ = True - dmatch _ [] = False - dmatch dds@(d:ds) (e:es) = - case compare d e of - LT -> False - EQ -> dmatch ds es - GT -> dmatch dds es - - ------------------------------------------------------------------------------- -addRoleData :: Text -> RoleValue -> Role -> Role -addRoleData k v (Role n d) = Role n $ M.insert k v d diff --git a/src/Control/Access/RoleBased/Types.hs b/src/Control/Access/RoleBased/Types.hs deleted file mode 100644 --- a/src/Control/Access/RoleBased/Types.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Control.Access.RoleBased.Types - ( Role(..) -- fixme: remove (..) - , RoleValue(..) -- fixme - , RoleValueMeta(..) - , RoleDataDefinition(..) - , RoleMetadata(..) - , Rule - , RuleChecker - ) where - -import Control.Access.RoleBased.Internal.Types diff --git a/src/Snap.hs b/src/Snap.hs --- a/src/Snap.hs +++ b/src/Snap.hs @@ -7,19 +7,11 @@ -} module Snap - ( module Control.Applicative - , module Control.Monad.State - , module Data.Lens.Common - , module Data.Lens.Template - , module Snap.Core + ( module Snap.Core , module Snap.Http.Server , module Snap.Snaplet ) where -import Control.Applicative -import Control.Monad.State -import Data.Lens.Common -import Data.Lens.Template import Snap.Core import Snap.Http.Server import Snap.Snaplet diff --git a/src/Snap/Loader/Devel.hs b/src/Snap/Loader/Devel.hs deleted file mode 100644 --- a/src/Snap/Loader/Devel.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------- --- | This module includes the machinery necessary to use hint to load --- action code dynamically. It includes a Template Haskell function --- to gather the necessary compile-time information about code --- location, compiler arguments, etc, and bind that information into --- the calls to the dynamic loader. -module Snap.Loader.Devel - ( loadSnapTH - ) where - ------------------------------------------------------------------------------- -#ifdef HINT_ENABLED -import Control.Monad (liftM2) -import Data.Char (isAlphaNum) -import Data.List -import Data.Maybe (maybeToList) -import Data.Time.Clock (diffUTCTime, getCurrentTime) -import Data.Typeable -import Language.Haskell.Interpreter hiding (lift, liftIO, typeOf) -import Language.Haskell.Interpreter.Unsafe -import Language.Haskell.TH -import System.Environment (getArgs) -import Snap.Core -import Snap.Loader.Devel.Signal -import Snap.Loader.Devel.Evaluator -import Snap.Loader.Devel.TreeWatcher -#else -import Language.Haskell.TH -#endif - - ------------------------------------------------------------------------------- --- | This function derives all the information necessary to use the interpreter --- from the compile-time environment, and compiles it in to the generated code. --- --- This could be considered a TH wrapper around a function --- --- > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ())) --- > -> [String] -> IO (a, Snap (), IO ()) --- --- with a magical implementation. The [String] argument is a list of --- directories to watch for updates to trigger a reloading. Directories --- containing code should be automatically picked up by this splice. --- --- The generated splice executes the initialiser once, sets up the interpreter --- for the load function, and returns the initializer's result along with the --- interpreter's proxy handler and cleanup actions. The behavior of the proxy --- actions will change to reflect changes in the watched files, reinterpreting --- the load function as needed and applying it to the initializer result. --- --- This will handle reloading the application successfully in most cases. The --- cases in which it is certain to fail are those involving changing the types --- of the initializer or the load function, or changing the compiler options --- required, such as by changing/adding dependencies in the project's .cabal --- file. In those cases, a full recompile will be needed. --- -loadSnapTH :: Q Exp -- ^ the initializer expression - -> Name -- ^ the name of the load function - -> [String] -- ^ a list of directories to watch in addition - -- to those containing code - -> Q Exp -#ifndef HINT_ENABLED -loadSnapTH _ _ _ = fail $ - concat [ "Snap was built without hint support. Hint " - , "support is necessary for development mode. " - , "Please reinstall snap with hint support.\n\n " - , " cabal install snap -fhint\n\n" ] -#else -loadSnapTH initializer action additionalWatchDirs = do - args <- runIO getArgs - - let opts = getHintOpts args - srcPaths = additionalWatchDirs ++ getSrcPaths args - - -- The first line is an extra type check to ensure the arguments - -- provided have the the correct types - [| do let _ = $initializer >>= $(varE action) - v <- $initializer - (handler, cleanup) <- hintSnap opts actMods srcPaths loadStr v - return (v, handler, cleanup) |] - where - actMods = maybeToList $ nameModule action - loadStr = nameBase action - - ------------------------------------------------------------------------------- --- | Convert the command-line arguments passed in to options for the --- hint interpreter. This is somewhat brittle code, based on a few --- experimental datapoints regarding the structure of the command-line --- arguments cabal produces. -getHintOpts :: [String] -> [String] -getHintOpts args = removeBad opts - where - -------------------------------------------------------------------------- - bad = ["-threaded", "-O"] - - -------------------------------------------------------------------------- - removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad) - - -------------------------------------------------------------------------- - hideAll = filter (== "-hide-all-packages") args - - -------------------------------------------------------------------------- - srcOpts = filter (\x -> "-i" `isPrefixOf` x - && not ("-idist" `isPrefixOf` x)) - args - - -------------------------------------------------------------------------- - toCopy = filter (not . isSuffixOf ".hs") $ - dropWhile (not . ("-package" `isPrefixOf`)) args - - -------------------------------------------------------------------------- - copy = map (intercalate " ") - . groupBy (\_ s -> not $ "-" `isPrefixOf` s) - - -------------------------------------------------------------------------- - opts = concat [hideAll, srcOpts, copy toCopy] - - ------------------------------------------------------------------------------- --- | This function extracts the source paths from the compilation args -getSrcPaths :: [String] -> [String] -getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg - where - srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x) - - ------------------------------------------------------------------------------- --- | This function creates the Snap handler that actually is responsible for --- doing the dynamic loading of actions via hint, given all of the --- configuration information that the interpreter needs. It also ensures safe --- concurrent access to the interpreter, and caches the interpreter results for --- a short time before allowing it to run again. --- --- Generally, this won't be called manually. Instead, loadSnapTH will generate --- a call to it at compile-time, calculating all the arguments from its --- environment. --- -hintSnap :: Typeable a - => [String] - -- ^ A list of command-line options for the interpreter - -> [String] - -- ^ A list of modules that need to be interpreted. This should - -- contain only the modules which contain the initialization, - -- cleanup, and handler actions. Everything else they require will - -- be loaded transitively. - -> [String] - -- ^ A list of paths to watch for updates - -> String - -- ^ The name of the function to load - -> a - -- ^ The value to apply the loaded function to - -> IO (Snap (), IO ()) -hintSnap opts modules srcPaths action value = - protectedHintEvaluator initialize test loader - - where - -------------------------------------------------------------------------- - witness x = undefined $ x `asTypeOf` value :: HintLoadable - - -------------------------------------------------------------------------- - -- This is somewhat fragile, and probably can be cleaned up with a future - -- version of Typeable. For the moment, and backwards-compatibility, this - -- is the approach being taken. - witnessModules = map (reverse . drop 1 . dropWhile (/= '.') . reverse) . - filter (elem '.') . groupBy typePart . show . typeOf $ - witness - - -------------------------------------------------------------------------- - typePart x y = (isAlphaNum x && isAlphaNum y) || x == '.' || y == '.' - - -------------------------------------------------------------------------- - interpreter = do - loadModules . nub $ modules - setImports . nub $ "Prelude" : witnessModules ++ modules - - f <- interpret action witness - return $ f value - - -------------------------------------------------------------------------- - loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter - - -------------------------------------------------------------------------- - formatOnError (Left err) = error $ format err - formatOnError (Right a) = a - - -------------------------------------------------------------------------- - loader = formatOnError `fmap` protectHandlers loadInterpreter - - -------------------------------------------------------------------------- - initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths - - -------------------------------------------------------------------------- - test (prevTime, ts) = do - now <- getCurrentTime - if diffUTCTime now prevTime < 3 - then return True - else checkTreeStatus ts - - ------------------------------------------------------------------------------- --- | Convert an InterpreterError to a String for presentation -format :: InterpreterError -> String -format (UnknownError e) = "Unknown interpreter error:\r\n\r\n" ++ e -format (NotAllowed e) = "Interpreter action not allowed:\r\n\r\n" ++ e -format (GhcException e) = "GHC error:\r\n\r\n" ++ e -format (WontCompile errs) = "Compile errors:\r\n\r\n" ++ - (intercalate "\r\n" $ nub $ map errMsg errs) - -#endif diff --git a/src/Snap/Loader/Devel/Evaluator.hs b/src/Snap/Loader/Devel/Evaluator.hs deleted file mode 100644 --- a/src/Snap/Loader/Devel/Evaluator.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Snap.Loader.Devel.Evaluator - ( HintLoadable - , protectedHintEvaluator - ) where - ------------------------------------------------------------------------------- -import Control.Exception -import Control.Monad (when) -import Control.Monad.Trans (liftIO) -import Control.Concurrent (ThreadId, forkIO, myThreadId) -import Control.Concurrent.MVar -import Prelude hiding (catch, init, any) -import Snap.Core (Snap) - - ------------------------------------------------------------------------------- --- | A type synonym to simply talking about the type loaded by hint. -type HintLoadable = IO (Snap (), IO ()) - - ------------------------------------------------------------------------------- --- | Convert an action to generate 'HintLoadable's into Snap and IO actions --- that handle periodic reloading. The resulting action will share initialized --- state until the next execution of the input action. At this time, the --- cleanup action will be executed. --- --- The first two arguments control when recompiles are done. The first argument --- is an action that is executed when compilation starts. The second is a --- function from the result of the first action to an action that determines --- whether the value from the previous compilation is still good. This --- abstracts out the strategy for determining when a cached result is no longer --- valid. --- --- If an exception is raised during the processing of the action, it will be --- thrown to all waiting threads, and for all requests made before the --- recompile condition is reached. -protectedHintEvaluator :: forall a. - IO a - -> (a -> IO Bool) - -> IO HintLoadable - -> IO (Snap (), IO ()) -protectedHintEvaluator start test getInternals = do - -- The list of requesters waiting for a result. Contains the ThreadId in - -- case of exceptions, and an empty MVar awaiting a successful result. - readerContainer <- newReaderContainer - - -- Contains the previous result and initialization value, and the time it - -- was stored, if a previous result has been computed. The result stored is - -- either the actual result and initialization result, or the exception - -- thrown by the calculation. - resultContainer <- newResultContainer - - -- The model used for the above MVars in the returned action is "keep them - -- full, unless updating them." In every case, when one of those MVars is - -- emptied, the next action is to fill that same MVar. This makes - -- deadlocking on MVar wait impossible. - let snap = do - let waitForNewResult :: IO (Snap ()) - waitForNewResult = do - -- Need to calculate a new result - tid <- myThreadId - reader <- newEmptyMVar - - readers <- takeMVar readerContainer - - -- Some strictness is employed to ensure the MVar - -- isn't holding on to a chain of unevaluated thunks. - let pair = (tid, reader) - newReaders = readers `seq` pair `seq` (pair : readers) - putMVar readerContainer $! newReaders - - -- If this is the first reader to queue, clean up the - -- previous state, if there was any, and then begin - -- evaluation of the new code and state. - when (null readers) $ do - let runAndFill = block $ do - -- run the cleanup action - previous <- readMVar resultContainer - unblock $ cleanup previous - - -- compile the new internals and initialize - stateInitializer <- unblock getInternals - res <- unblock stateInitializer - - let a = fst res - - clearAndNotify (Right res) - (flip putMVar a . snd) - - killWaiting :: SomeException -> IO () - killWaiting e = block $ do - clearAndNotify (Left e) (flip throwTo e . fst) - throwIO e - - clearAndNotify r f = do - a <- unblock start - _ <- swapMVar resultContainer $ Just (r, a) - allReaders <- swapMVar readerContainer [] - mapM_ f allReaders - - _ <- forkIO $ runAndFill `catch` killWaiting - return () - - -- Wait for the evaluation of the action to complete, - -- and return its result. - takeMVar reader - - existingResult <- liftIO $ readMVar resultContainer - - getResult <- liftIO $ case existingResult of - Just (res, a) -> do - -- There's an existing result. Check for validity - valid <- test a - case (valid, res) of - (True, Right (x, _)) -> return x - (True, Left e) -> throwIO e - (False, _) -> waitForNewResult - Nothing -> waitForNewResult - getResult - - clean = do - let msg = "invalid dynamic loader state. " ++ - "The cleanup action has been executed" - contents <- swapMVar resultContainer $ error msg - cleanup contents - - return (snap, clean) - - where - newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))]) - newReaderContainer = newMVar [] - - newResultContainer :: IO (MVar (Maybe (Either SomeException - (Snap (), IO ()), a))) - newResultContainer = newMVar Nothing - - cleanup (Just (Right (_, clean), _)) = clean - cleanup _ = return () diff --git a/src/Snap/Loader/Devel/Signal.hs b/src/Snap/Loader/Devel/Signal.hs deleted file mode 100644 --- a/src/Snap/Loader/Devel/Signal.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE CPP #-} -module Snap.Loader.Devel.Signal (protectHandlers) where - ------------------------------------------------------------------------------- -import Control.Exception (bracket) - - -#ifdef mingw32_HOST_OS - - ------------- - -- windows -- - ------------- ------------------------------------------------------------------------------- -import GHC.ConsoleHandler as C - -saveHandlers :: IO C.Handler -saveHandlers = C.installHandler Ignore - -restoreHandlers :: C.Handler -> IO C.Handler -restoreHandlers = C.installHandler ------------------------------------------------------------------------------- - - -#else - - ----------- - -- posix -- - ----------- ------------------------------------------------------------------------------- -import qualified System.Posix.Signals as S - -helper :: S.Handler -> S.Signal -> IO S.Handler -helper handler signal = S.installHandler signal handler Nothing - -signals :: [S.Signal] -signals = [ S.sigQUIT - , S.sigINT - , S.sigHUP - , S.sigTERM - ] - -saveHandlers :: IO [S.Handler] -saveHandlers = mapM (helper S.Ignore) signals - -restoreHandlers :: [S.Handler] -> IO [S.Handler] -restoreHandlers h = sequence $ zipWith helper h signals ------------------------------------------------------------------------------- - -#endif - - ---------- - -- both -- - ---------- ------------------------------------------------------------------------------- -protectHandlers :: IO a -> IO a -protectHandlers a = bracket saveHandlers restoreHandlers $ const a ------------------------------------------------------------------------------- diff --git a/src/Snap/Loader/Devel/TreeWatcher.hs b/src/Snap/Loader/Devel/TreeWatcher.hs deleted file mode 100644 --- a/src/Snap/Loader/Devel/TreeWatcher.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Snap.Loader.Devel.TreeWatcher - ( TreeStatus - , getTreeStatus - , checkTreeStatus - ) where - ------------------------------------------------------------------------------- -import Control.Applicative -import System.Directory -import System.Directory.Tree -import System.Time - - ------------------------------------------------------------------------------- --- | An opaque representation of the contents and last modification --- times of a forest of directory trees. -data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime] - - ------------------------------------------------------------------------------- --- | Create a 'TreeStatus' for later checking with 'checkTreeStatus' -getTreeStatus :: [FilePath] -> IO TreeStatus -getTreeStatus = liftA2 (<$>) TS readModificationTimes - - ------------------------------------------------------------------------------- --- | Checks that all the files present in the initial set of paths are --- the exact set of files currently present, with unchanged modifcations times -checkTreeStatus :: TreeStatus -> IO Bool -checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths - where - check = and . zipWith (==) entries - - ------------------------------------------------------------------------------- --- | This is the core of the functions in this module. It converts a --- list of filepaths into a list of 'AnchoredDirTree' annotated with --- the modification times of the files located in those paths. -readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime] -readModificationTimes = mapM $ readDirectoryWith getModificationTime diff --git a/src/Snap/Loader/Prod.hs b/src/Snap/Loader/Prod.hs deleted file mode 100644 --- a/src/Snap/Loader/Prod.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Snap.Loader.Prod - ( loadSnapTH - ) where - ------------------------------------------------------------------------------- -import Language.Haskell.TH - - ------------------------------------------------------------------------------- --- | This function provides a non-magical type-compatible loader for --- the one in Snap.Loader.Devel, allowing switching one import to --- provide production-mode compilation. --- --- This could be considered a TH wrapper around a function --- --- > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ())) --- > -> [String] -> IO (a, Snap (), IO ()) --- --- The third argument is unused, and only present for --- type-compatibility with Snap.Loader.Devel -loadSnapTH :: Q Exp -> Name -> [String] -> Q Exp -loadSnapTH initializer action _additionalWatchDirs = - [| do value <- $initializer - (site, conf) <- $(varE action) value - return (value, site, conf) |] diff --git a/src/Snap/Snaplet.hs b/src/Snap/Snaplet.hs --- a/src/Snap/Snaplet.hs +++ b/src/Snap/Snaplet.hs @@ -46,15 +46,15 @@ Snaplet , SnapletConfig + -- * Lenses + -- $lenses + -- * Snaplet Helper Functions -- $snapletHelpers , snapletConfig , snapletValue , subSnaplet - -- * Lenses - -- $lenses - -- * MonadSnaplet -- $monadSnaplet , MonadSnaplet(..) @@ -64,6 +64,7 @@ , getSnapletDescription , getSnapletUserConfig , getSnapletRootURL + , snapletURL , getRoutePattern , setRoutePattern @@ -91,21 +92,30 @@ , addPostInitHook , addPostInitHookBase , printInfo + , getRoutes + , getEnvironment -- * Routes -- $routes , addRoutes - , wrapHandlers + , wrapSite -- * Handlers , Handler + , failIfNotLocal , reloadSite + , modifyMaster , bracketHandler -- * Serving Applications , runSnaplet , combineConfig , serveSnaplet + , serveSnapletNoArgParsing + , loadAppConfig + + -- * Snaplet Lenses + , SnapletLens ) where @@ -135,7 +145,7 @@ -- contains all of the application state; we call this state the \"base\" -- state. -- --- We provide a couple of helper functions for working with Snaplet types. +-- We export several helper lenses for working with Snaplet types. -- $lenses -- In the example above, the @Foo@ snaplet has to be written to work with any @@ -144,53 +154,52 @@ -- /within the context/ of the base state. Given that Haskell datatypes are -- pure, how do you allow for this? -- --- Our solution is to use /lenses/, as defined in the @data-lens@ library --- (). A lens, notated as --- follows: +-- Our solution is to use /lenses/, as defined in Edward Kmett's @lens@ +-- library (). A lens, notated +-- as follows: -- --- > Lens a b +-- > SimpleLens a b -- --- is a \"getter\" and a \"setter\" rolled up into one. The @data-lens@ --- library provides the following functions: +-- is conceptually a \"getter\" and a \"setter\" rolled up into one. The +-- @lens@ library provides the following functions: -- --- > getL :: (Lens a b) -> a -> b --- > setL :: (Lens a b) -> b -> a -> a --- > modL :: (Lens a b) -> (b -> b) -> a -> a +-- > view :: (SimpleLens a b) -> a -> b +-- > set :: (SimpleLens a b) -> b -> a -> a +-- > over :: (SimpleLens a b) -> (b -> b) -> a -> a -- -- which allow you to get, set, and modify a value of type @b@ within the --- context of type of type @a@. The @data-lens@ package comes with a Template --- Haskell function called 'makeLenses', which auto-magically defines a lens --- for every record field having a name beginning with an underscore. In the --- @App@ example above, adding the declaration: +-- context of type @a@. The @lens@ package comes with a Template Haskell +-- function called 'makeLenses', which auto-magically defines a lens for every +-- record field having a name beginning with an underscore. In the @App@ +-- example above, adding the declaration: -- --- > makeLenses [''App] +-- > makeLenses ''App -- -- would define lenses: -- --- > foo :: Lens App (Snaplet Foo) --- > bar :: Lens App (Snaplet Bar) --- > someNonSnapletData :: Lens App String +-- > foo :: SimpleLens App (Snaplet Foo) +-- > bar :: SimpleLens App (Snaplet Bar) +-- > someNonSnapletData :: SimpleLens App String -- --- The coolest thing about @data-lens@ lenses is that they /compose/, using --- the "Control.Category"'s generalization of the @(.)@ operator. If the @Foo@ --- type had a field of type @Quux@ within it with a lens @quux :: Lens Foo --- Quux@, then you could create a lens of type @Lens App Quux@ by composition: +-- The coolest thing about @lens@ lenses is that they /compose/ using the +-- @(.)@ operator. If the @Foo@ type had a field of type @Quux@ within it with +-- a lens @quux :: SimpleLens Foo Quux@, then you could create a lens of type +-- @SimpleLens App Quux@ by composition: -- --- > import Control.Category --- > import Prelude hiding ((.)) -- you have to hide (.) from the Prelude --- > -- to use Control.Category.(.) +-- > import Control.Lens -- > -- > data Foo = Foo { _quux :: Quux } --- > makeLenses [''Foo] +-- > makeLenses ''Foo -- > -- > -- snapletValue is defined in the framework: --- > snapletValue :: Lens (Snaplet a) a +-- > snapletValue :: SimpleLens (Snaplet a) a -- > --- > appQuuxLens :: Lens App Quux --- > appQuuxLens = quux . snapletValue . foo +-- > appQuuxLens :: SimpleLens App Quux +-- > appQuuxLens = foo . snapletValue . quux -- --- Lens composition is very similar to function composition, but it gives you --- a composed getter and setter at the same time. +-- Lens composition is very similar to function composition except it works in +-- the opposite direction (think Java-style System.out.println ordering) and +-- it gives you a composed getter and setter at the same time. -- $monadSnaplet -- The primary abstraction in the snaplet infrastructure is a combination of @@ -200,7 +209,7 @@ -- state. This allows quux snaplet functions to access and modify the Quux -- data structure without knowing anything about the App or Foo data -- structures. It also lets other snaplets call functions from the quux --- snaplet if they have the quux snaplet's lens @Lens App (Snaplet Quux)@. +-- snaplet if they have the quux snaplet's lens @SimpleLens App (Snaplet Quux)@. -- We can view our application as a tree of snaplets and other pieces of data. -- The lenses are like pointers to nodes of the tree. If you have a pointer to -- a node, you can access the node and all of its children without knowing @@ -249,7 +258,7 @@ -- $routes -- Snaplet initializers are also responsible for setting up any routes defined -- by the snaplet. To do that you'll usually use either 'addRoutes' or --- 'wrapHandlers'. +-- 'wrapSite'. {- @@ -281,6 +290,7 @@ Snaplet) we want to use as well as any other state we might want.} > module MyApp where +> import Control.Lens > import Snap.Snaplet > import Snap.Snaplet.Heist > @@ -291,7 +301,7 @@ > , _companyName :: String > } > -> makeLenses [''App] +> makeLenses ''App The next thing we need to do is define an initializer. @@ -302,7 +312,7 @@ > bs <- nestSnaplet "" $ nameSnaplet "baz" $ barInit heist > addRoutes [ ("/hello", writeText "hello world") > ] -> wrapHandlers (<|> with heist heistServe) +> wrapSite (<|> with heist heistServe) > return $ App hs fs bs "fooCorp" Then we define a simple main to run the application. diff --git a/src/Snap/Snaplet/Auth.hs b/src/Snap/Snaplet/Auth.hs --- a/src/Snap/Snaplet/Auth.hs +++ b/src/Snap/Snaplet/Auth.hs @@ -43,11 +43,10 @@ , UserId(..) , Password(..) , AuthFailure(..) - , BackendError(..) , Role(..) -- * Other Utilities - , authSettingsFromConfig + , authSettingsFromConfig , withBackend , encryptPassword , checkPassword @@ -61,9 +60,14 @@ , loginUser , logoutUser , requireUser + , setPasswordResetToken + , clearPasswordResetToken -- * Splice helpers , addAuthSplices + , compiledAuthSplices + , userCSplices + , userISplices , ifLoggedIn , ifLoggedOut , loggedInUser diff --git a/src/Snap/Snaplet/Auth/AuthManager.hs b/src/Snap/Snaplet/Auth/AuthManager.hs --- a/src/Snap/Snaplet/Auth/AuthManager.hs +++ b/src/Snap/Snaplet/Auth/AuthManager.hs @@ -20,7 +20,6 @@ ------------------------------------------------------------------------------ import Data.ByteString (ByteString) -import Data.Lens.Lazy import Data.Text (Text) import Data.Time import Web.ClientSession @@ -33,12 +32,11 @@ ------------------------------------------------------------------------------ -- | Creates a new user from a username and password. -- --- May throw a "DuplicateLogin" if given username is not unique buildAuthUser :: IAuthBackend r => r -- ^ An auth backend -> Text -- ^ Username -> ByteString -- ^ Password - -> IO AuthUser + -> IO (Either AuthFailure AuthUser) buildAuthUser r unm pass = do now <- getCurrentTime let au = defAuthUser { @@ -54,15 +52,14 @@ ------------------------------------------------------------------------------ -- | All storage backends need to implement this typeclass -- --- Backend operations may throw 'BackendError's class IAuthBackend r where - -- | Create or update the given 'AuthUser' record. If the 'userId' in the - -- 'AuthUser' already exists in the database, then that user's information - -- should be updated. If it does not exist, then a new user should be - -- created. - save :: r -> AuthUser -> IO AuthUser + -- | Create or update the given 'AuthUser' record. A 'userId' of Nothing + -- indicates that a new user should be created, otherwise the user + -- information for that userId should be updated. + save :: r -> AuthUser -> IO (Either AuthFailure AuthUser) lookupByUserId :: r -> UserId -> IO (Maybe AuthUser) lookupByLogin :: r -> Text -> IO (Maybe AuthUser) + lookupByEmail :: r -> Text -> IO (Maybe AuthUser) lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser) destroy :: r -> AuthUser -> IO () @@ -73,7 +70,7 @@ backend :: r -- ^ Storage back-end - , session :: Lens b (Snaplet SessionManager) + , session :: SnapletLens b SessionManager -- ^ A lens pointer to a SessionManager , activeUser :: Maybe AuthUser @@ -85,6 +82,9 @@ , rememberCookieName :: ByteString -- ^ Cookie name for the remember token + , rememberCookieDomain :: Maybe ByteString + -- ^ Domain for which remember cookie will be created. + , rememberPeriod :: Maybe Int -- ^ Remember period in seconds. Defaults to 2 weeks. @@ -102,6 +102,6 @@ save AuthManager{..} u = save backend u lookupByUserId AuthManager{..} u = lookupByUserId backend u lookupByLogin AuthManager{..} u = lookupByLogin backend u + lookupByEmail AuthManager{..} u = lookupByEmail backend u lookupByRememberToken AuthManager{..} u = lookupByRememberToken backend u destroy AuthManager{..} u = destroy backend u - diff --git a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs --- a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs +++ b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs @@ -1,33 +1,38 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} - module Snap.Snaplet.Auth.Backends.JsonFile ( initJsonFileAuthManager , mkJsonAuthMgr ) where -import Control.Applicative -import Control.Monad.CatchIO (throw) +import Control.Applicative ((<|>)) +import Control.Monad (join) import Control.Monad.State import Control.Concurrent.STM import Data.Aeson -import qualified Data.Attoparsec as Atto +import Data.Aeson.Parser (json) +import qualified Data.Attoparsec.ByteString as Atto import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString as B import qualified Data.Map as HM import Data.Map (Map) -import Data.Maybe (fromJust, isJust) +import Data.Maybe (fromJust, isJust, listToMaybe) +import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text as T -import Data.Lens.Lazy import Data.Time import Web.ClientSession import System.Directory +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + import Snap.Snaplet import Snap.Snaplet.Auth.Types import Snap.Snaplet.Auth.AuthManager @@ -38,12 +43,12 @@ ------------------------------------------------------------------------------ -- | Initialize a JSON file backed 'AuthManager' initJsonFileAuthManager :: AuthSettings - -- ^ Authentication settings for your app - -> Lens b (Snaplet SessionManager) - -- ^ Lens into a 'SessionManager' auth snaplet will + -- ^ Authentication settings for your app + -> SnapletLens b SessionManager + -- ^ Lens into a 'SessionManager' auth snaplet will -- use -> FilePath - -- ^ Where to store user data as JSON + -- ^ Where to store user data as JSON -> SnapletInit b (AuthManager b) initJsonFileAuthManager s l db = do makeSnaplet @@ -59,6 +64,7 @@ , activeUser = Nothing , minPasswdLen = asMinPasswdLen s , rememberCookieName = asRememberCookieName s + , rememberCookieDomain = Nothing , rememberPeriod = asRememberPeriod s , siteKey = key , lockout = asLockout s @@ -87,17 +93,25 @@ ------------------------------------------------------------------------------ type UserIdCache = Map UserId AuthUser +#if !MIN_VERSION_aeson(1,0,0) +-- In aeson >= 1 these instances are not needed because we have +-- derived ToJSONKey/FromJSONKey instances for UserId. instance ToJSON UserIdCache where toJSON m = toJSON $ HM.toList m instance FromJSON UserIdCache where parseJSON = fmap HM.fromList . parseJSON +#endif ------------------------------------------------------------------------------ type LoginUserCache = Map Text UserId ------------------------------------------------------------------------------ +type EmailUserCache = Map Text UserId + + +------------------------------------------------------------------------------ type RemTokenUserCache = Map Text UserId @@ -107,6 +121,7 @@ data UserCache = UserCache { uidCache :: UserIdCache -- ^ the actual datastore , loginCache :: LoginUserCache -- ^ fast lookup for login field + , emailCache :: EmailUserCache -- ^ fast lookup for email field , tokenCache :: RemTokenUserCache -- ^ fast lookup for remember tokens , uidCounter :: Int -- ^ user id counter } @@ -117,6 +132,7 @@ defUserCache = UserCache { uidCache = HM.empty , loginCache = HM.empty + , emailCache = HM.empty , tokenCache = HM.empty , uidCounter = 0 } @@ -149,7 +165,9 @@ ------------------------------------------------------------------------------ -jsonFileSave :: JsonFileAuthManager -> AuthUser -> IO AuthUser +jsonFileSave :: JsonFileAuthManager + -> AuthUser + -> IO (Either AuthFailure AuthUser) jsonFileSave mgr u = do now <- getCurrentTime oldByLogin <- lookupByLogin mgr (userLogin u) @@ -169,17 +187,17 @@ return $! Right $! (cache', u') case res of - Left e -> throw e + Left _ -> return $! Left BackendError Right (cache', u') -> do dumpToDisk cache' - return $! u' + return $! Right u' where -------------------------------------------------------------------------- create :: UserCache -> UTCTime -> (Maybe AuthUser) - -> STM (Either BackendError (UserCache, AuthUser)) + -> STM (Either AuthFailure (UserCache, AuthUser)) create cache now old = do case old of Just _ -> return $! Left DuplicateLogin @@ -190,6 +208,8 @@ return $! cache { uidCache = HM.insert uid' u' $ uidCache cache , loginCache = HM.insert (userLogin u') uid' $ loginCache cache + , emailCache = maybe id (\em -> HM.insert em uid') (userEmail u) $ + emailCache cache , tokenCache = case userRememberToken u' of Nothing -> tokenCache cache Just x -> HM.insert x uid' $ tokenCache cache @@ -202,16 +222,17 @@ update :: UserCache -> UTCTime -> (Maybe AuthUser) - -> STM (Either BackendError (UserCache, AuthUser)) + -> STM (Either AuthFailure (UserCache, AuthUser)) update cache now old = case old of - Nothing -> return $! Left $ - BackendError "User not found; should never happen" + Nothing -> return $! Left UserNotFound Just x -> do let oldLogin = userLogin x + let oldEmail = userEmail x let oldToken = userRememberToken x let uid = fromJust $ userId u let newLogin = userLogin u + let newEmail = userEmail u let newToken = userRememberToken u let lc = if oldLogin /= userLogin u @@ -220,6 +241,16 @@ loginCache cache else loginCache cache + let ec = if oldEmail /= newEmail + then (case (oldEmail, newEmail) of + (Nothing, Nothing) -> id + (Just e, Nothing) -> HM.delete e + (Nothing, Just e ) -> HM.insert e uid + (Just e, Just e') -> HM.insert e' uid . + HM.delete e + ) (emailCache cache) + else emailCache cache + let tc = if oldToken /= newToken && isJust oldToken then HM.delete (fromJust oldToken) $ loginCache cache else tokenCache cache @@ -233,6 +264,7 @@ let new = cache { uidCache = HM.insert uid u' $ uidCache cache , loginCache = lc + , emailCache = ec , tokenCache = tc' } @@ -266,6 +298,16 @@ f cache = getUid >>= getUser cache where getUid = HM.lookup login (loginCache cache) + lookupByEmail mgr email = withCache mgr f + where + f cache = getEmail >>= getUser cache + where getEmail = case HM.lookup email (emailCache cache) of + Just u -> return u + Nothing -> (join . fmap userId . + listToMaybe . HM.elems $ + HM.filter ((== Just email) . userEmail) + (uidCache cache)) + lookupByRememberToken mgr token = withCache mgr f where f cache = getUid >>= getUser cache @@ -299,6 +341,7 @@ toJSON uc = object [ "uidCache" .= uidCache uc , "loginCache" .= loginCache uc + , "emailCache" .= emailCache uc , "tokenCache" .= tokenCache uc , "uidCounter" .= uidCounter uc ] @@ -310,8 +353,8 @@ UserCache <$> v .: "uidCache" <*> v .: "loginCache" + <*> (v .: "emailCache" <|> pure mempty) -- Old versions of users.json do + -- not carry this field <*> v .: "tokenCache" <*> v .: "uidCounter" parseJSON _ = error "Unexpected JSON input" - - diff --git a/src/Snap/Snaplet/Auth/Handlers.hs b/src/Snap/Snaplet/Auth/Handlers.hs --- a/src/Snap/Snaplet/Auth/Handlers.hs +++ b/src/Snap/Snaplet/Auth/Handlers.hs @@ -11,17 +11,16 @@ ------------------------------------------------------------------------------ import Control.Applicative -import Control.Monad.CatchIO (throw) +import Control.Monad (join, liftM, liftM2) import Control.Monad.State -import Control.Monad.Trans.Error import Control.Monad.Trans.Maybe import Data.ByteString (ByteString) -import Data.Lens.Lazy -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe import Data.Serialize hiding (get) import Data.Time import Data.Text.Encoding (decodeUtf8) -import Data.Text (Text) +import Data.Text (Text, null, strip) +import Prelude hiding (null) import Web.ClientSession ------------------------------------------------------------------------------ import Snap.Core @@ -39,12 +38,15 @@ ------------------------------------------------------------------------------ -- | Create a new user from just a username and password -- --- May throw a "DuplicateLogin" if given username is not unique. --- createUser :: Text -- ^ Username -> ByteString -- ^ Password - -> Handler b (AuthManager b) AuthUser -createUser unm pwd = withBackend (\r -> liftIO $ buildAuthUser r unm pwd) + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +createUser unm pwd + | null $ strip unm = return $ Left UsernameMissing + | otherwise = do + uExists <- usernameExists unm + if uExists then return $ Left DuplicateLogin + else withBackend $ \r -> liftIO $ buildAuthUser r unm pwd ------------------------------------------------------------------------------ @@ -59,28 +61,29 @@ ------------------------------------------------------------------------------ -- | Lookup a user by her username, check given password and perform login -- -loginByUsername :: ByteString -- ^ Username/login for user +loginByUsername :: Text -- ^ Username/login for user -> Password -- ^ Should be ClearText -> Bool -- ^ Set remember token? -> Handler b (AuthManager b) (Either AuthFailure AuthUser) -loginByUsername _ (Encrypted _) _ = - error "Cannot login with encrypted password" +loginByUsername _ (Encrypted _) _ = return $ Left EncryptedPassword loginByUsername unm pwd shouldRemember = do sk <- gets siteKey cn <- gets rememberCookieName + cd <- gets rememberCookieDomain rp <- gets rememberPeriod - withBackend $ loginByUsername' sk cn rp + withBackend $ loginByUsername' sk cn cd rp where -------------------------------------------------------------------------- loginByUsername' :: (IAuthBackend t) => Key -> ByteString + -> Maybe ByteString -> Maybe Int -> t -> Handler b (AuthManager b) (Either AuthFailure AuthUser) - loginByUsername' sk cn rp r = - liftIO (lookupByLogin r $ decodeUtf8 unm) >>= + loginByUsername' sk cn cd rp r = + liftIO (lookupByLogin r unm) >>= maybe (return $! Left UserNotFound) found where @@ -94,7 +97,7 @@ token <- gets randomNumberGenerator >>= liftIO . randomToken 64 - setRememberToken sk cn rp token + setRememberToken sk cn cd rp token let user' = user { userRememberToken = Just (decodeUtf8 token) @@ -109,18 +112,21 @@ ------------------------------------------------------------------------------ -- | Remember user from the remember token if possible and perform login -- -loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser) +loginByRememberToken :: Handler b (AuthManager b) (Either AuthFailure AuthUser) loginByRememberToken = withBackend $ \impl -> do key <- gets siteKey cookieName_ <- gets rememberCookieName period <- gets rememberPeriod - runMaybeT $ do + res <- runMaybeT $ do token <- MaybeT $ getRememberToken key cookieName_ period - user <- MaybeT $ liftIO $ lookupByRememberToken impl - $ decodeUtf8 token - lift $ forceLogin user - return user + MaybeT $ liftIO $ lookupByRememberToken impl $ decodeUtf8 token + case res of + Nothing -> return $ Left $ AuthError + "loginByRememberToken: no remember token" + Just user -> do + forceLogin user + return $ Right user ------------------------------------------------------------------------------ @@ -131,7 +137,8 @@ s <- gets session withTop s $ withSession s removeSessionUserId rc <- gets rememberCookieName - forgetRememberToken rc + rd <- gets rememberCookieDomain + expireSecureCookie rc rd modify $ \mgr -> mgr { activeUser = Nothing } @@ -143,7 +150,7 @@ s <- gets session uid <- withTop s getSessionUserId case uid of - Nothing -> loginByRememberToken + Nothing -> either (const Nothing) Just <$> loginByRememberToken Just uid' -> liftIO $ lookupByUserId r uid' @@ -157,17 +164,15 @@ ------------------------------------------------------------------------------ -- | Create or update a given user -- --- May throw a 'BackendError' if something goes wrong. --- -saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser -saveUser u = withBackend $ liftIO . flip save u +saveUser :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +saveUser u + | null $ userLogin u = return $ Left UsernameMissing + | otherwise = withBackend $ \r -> liftIO $ save r u ------------------------------------------------------------------------------ -- | Destroy the given user -- --- May throw a 'BackendError' if something goes wrong. --- destroyUser :: AuthUser -> Handler b (AuthManager b) () destroyUser u = withBackend $ liftIO . flip destroy u @@ -181,7 +186,8 @@ -- -- This will save the user to the backend. -- -markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser +markAuthFail :: AuthUser + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) markAuthFail u = withBackend $ \r -> do lo <- gets lockout incFailCtr u >>= checkLockout lo >>= liftIO . save r @@ -210,7 +216,8 @@ -- -- This will save the user to the backend. -- -markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser +markAuthSuccess :: AuthUser + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) markAuthSuccess u = withBackend $ \r -> incLoginCtr u >>= updateIp >>= @@ -223,7 +230,7 @@ -------------------------------------------------------------------------- updateIp u' = do - ip <- rqRemoteAddr <$> getRequest + ip <- rqClientAddr <$> getRequest return $ u' { userLastLoginIp = userCurrentLoginIp u' , userCurrentLoginIp = Just ip } @@ -267,6 +274,7 @@ Nothing -> auth u where + auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser) auth user = case authenticatePassword user pw of Just e -> do @@ -276,8 +284,7 @@ Nothing -> do forceLogin user modify (\mgr -> mgr { activeUser = Just user }) - user' <- markAuthSuccess user - return $ Right user' + markAuthSuccess user ------------------------------------------------------------------------------ @@ -287,14 +294,14 @@ -- who she says she is. -- forceLogin :: AuthUser -- ^ An existing user, somehow looked up from db - -> Handler b (AuthManager b) (Either AuthFailure AuthUser) + -> Handler b (AuthManager b) (Either AuthFailure ()) forceLogin u = do s <- gets session - withSession s $ do + withSession s $ case userId u of Just x -> do withTop s (setSessionUserId x) - return $ Right u + return $ Right () Nothing -> return . Left $ AuthError $ "forceLogin: Can't force the login of a user " ++ "without userId" @@ -318,15 +325,11 @@ setRememberToken :: (Serialize t, MonadSnap m) => Key -> ByteString + -> Maybe ByteString -> Maybe Int -> t -> m () -setRememberToken sk rc rp token = setSecureCookie rc sk rp token - - ------------------------------------------------------------------------------- -forgetRememberToken :: MonadSnap m => ByteString -> m () -forgetRememberToken rc = expireCookie rc (Just "/") +setRememberToken sk rc rd rp token = setSecureCookie rc rd sk rp token ------------------------------------------------------------------------------ @@ -348,7 +351,7 @@ getSessionUserId :: Handler b SessionManager (Maybe UserId) getSessionUserId = do uid <- getFromSession "__user_id" - return $ uid >>= return . UserId + return $ liftM UserId uid ------------------------------------------------------------------------------ @@ -374,7 +377,7 @@ -- cacheOrLookup :: Handler b (AuthManager b) (Maybe AuthUser) - -- ^ Lookup action to perform if request local cache is empty + -- ^ Lookup action to perform if request local cache is empty -> Handler b (AuthManager b) (Maybe AuthUser) cacheOrLookup f = do au <- gets activeUser @@ -392,49 +395,66 @@ registerUser :: ByteString -- ^ Login field -> ByteString -- ^ Password field - -> Handler b (AuthManager b) AuthUser + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) registerUser lf pf = do l <- fmap decodeUtf8 <$> getParam lf p <- getParam pf - case liftM2 (,) l p of - Nothing -> throw PasswordMissing - Just (lgn, pwd) -> createUser lgn pwd + let l' = maybe (Left UsernameMissing) Right l + let p' = maybe (Left PasswordMissing) Right p + -- In case of multiple AuthFailure, the first available one + -- will be propagated. + case liftM2 (,) l' p' of + Left e -> return $ Left e + Right (lgn, pwd) -> createUser lgn pwd + + ------------------------------------------------------------------------------ -- | A 'MonadSnap' handler that processes a login form. -- -- The request paremeters are passed to 'performLogin' -- +-- To make your users stay logged in for longer than the session replay +-- prevention timeout, you must pass a field name as the third parameter and +-- that field must be set to a value of \"1\" by the submitting form. This +-- lets you use a user selectable check box. Or if you want user remembering +-- always turned on, you can use a hidden form field. loginUser :: ByteString - -- ^ Username field + -- ^ Username field -> ByteString - -- ^ Password field + -- ^ Password field -> Maybe ByteString - -- ^ Remember field; Nothing if you want no remember function. + -- ^ Remember field; Nothing if you want no remember function. -> (AuthFailure -> Handler b (AuthManager b) ()) - -- ^ Upon failure + -- ^ Upon failure -> Handler b (AuthManager b) () - -- ^ Upon success + -- ^ Upon success -> Handler b (AuthManager b) () -loginUser unf pwdf remf loginFail loginSucc = do - runErrorT go >>= either loginFail (const loginSucc) +loginUser unf pwdf remf loginFail loginSucc = + loginUser' unf pwdf remf >>= either loginFail (const loginSucc) - where - go = do - mbUsername <- getParam unf - mbPassword <- getParam pwdf - remember <- (runMaybeT $ do - field <- MaybeT $ return remf - value <- MaybeT $ getParam field - return $ value == "1" - ) >>= return . fromMaybe False +------------------------------------------------------------------------------ +loginUser' :: ByteString + -> ByteString + -> Maybe ByteString + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +loginUser' unf pwdf remf = do + mbUsername <- getParam unf + mbPassword <- getParam pwdf + remember <- liftM (fromMaybe False) + (runMaybeT $ + do field <- MaybeT $ return remf + value <- MaybeT $ getParam field + return $ value == "1" || value == "on") - password <- maybe (throwError PasswordMissing) return mbPassword - username <- maybe (fail "Username is missing") return mbUsername - lift $ loginByUsername username (ClearText password) remember + case mbUsername of + Nothing -> return $ Left UsernameMissing + Just u -> case mbPassword of + Nothing -> return $ Left PasswordMissing + Just p -> loginByUsername (decodeUtf8 u) (ClearText p) remember ------------------------------------------------------------------------------ @@ -452,12 +472,12 @@ -- This function has no DB cost - only checks to see if a user_id is present -- in the current session. -- -requireUser :: Lens b (Snaplet (AuthManager b)) - -- ^ Lens reference to an "AuthManager" +requireUser :: SnapletLens b (AuthManager b) + -- ^ Lens reference to an "AuthManager" -> Handler b v a - -- ^ Do this if no authenticated user is present. + -- ^ Do this if no authenticated user is present. -> Handler b v a - -- ^ Do this if an authenticated user is present. + -- ^ Do this if an authenticated user is present. -> Handler b v a requireUser auth bad good = do loggedIn <- withTop auth isLoggedIn @@ -478,5 +498,49 @@ -- ^ The function to run with the handler. -> Handler b (AuthManager v) a withBackend f = join $ do - (AuthManager backend_ _ _ _ _ _ _ _ _) <- get + (AuthManager backend_ _ _ _ _ _ _ _ _ _) <- get return $ f backend_ + + +------------------------------------------------------------------------------ +-- | This function generates a random password reset token and stores it in +-- the database for the user. Call this function when a user forgets their +-- password. Then use the token to autogenerate a link that the user can +-- visit to reset their password. This function also sets a timestamp so the +-- reset token can be expired. +setPasswordResetToken :: Text -> Handler b (AuthManager b) (Maybe Text) +setPasswordResetToken login = do + tokBS <- liftIO . randomToken 40 =<< gets randomNumberGenerator + let token = decodeUtf8 tokBS + now <- liftIO getCurrentTime + success <- modPasswordResetToken login (Just token) (Just now) + return $ if success then Just token else Nothing + + +------------------------------------------------------------------------------ +-- | Clears a user's password reset token. Call this when the user +-- successfully changes their password to ensure that the password reset link +-- cannot be used again. +clearPasswordResetToken :: Text -> Handler b (AuthManager b) Bool +clearPasswordResetToken login = modPasswordResetToken login Nothing Nothing + + +------------------------------------------------------------------------------ +-- | Helper function used for setting and clearing the password reset token +-- and associated timestamp. +modPasswordResetToken :: Text + -> Maybe Text + -> Maybe UTCTime + -> Handler v (AuthManager v) Bool +modPasswordResetToken login token timestamp = do + res <- runMaybeT $ do + u <- MaybeT $ withBackend $ \b -> liftIO $ lookupByLogin b login + lift $ saveUser $ u + { userResetToken = token + , userResetRequestedAt = timestamp + } + return () + return $ maybe False (\_ -> True) res + + + diff --git a/src/Snap/Snaplet/Auth/SpliceHelpers.hs b/src/Snap/Snaplet/Auth/SpliceHelpers.hs --- a/src/Snap/Snaplet/Auth/SpliceHelpers.hs +++ b/src/Snap/Snaplet/Auth/SpliceHelpers.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-| @@ -11,72 +13,190 @@ -} module Snap.Snaplet.Auth.SpliceHelpers - ( - addAuthSplices + ( addAuthSplices + , compiledAuthSplices + , userCSplices + , userISplices , ifLoggedIn , ifLoggedOut , loggedInUser + , cIfLoggedIn + , cIfLoggedOut + , cLoggedInUser ) where -import Data.Lens.Lazy +------------------------------------------------------------------------------ +import Control.Lens +import Control.Monad.Trans +import Data.Map.Syntax ((##), mapV) +import Data.Maybe +import qualified Data.Text as T +import Data.Text.Encoding import qualified Text.XmlHtml as X -import Text.Templating.Heist - +import Heist +import qualified Heist.Interpreted as I +import qualified Heist.Compiled as C +import Heist.Splices import Snap.Snaplet import Snap.Snaplet.Auth.AuthManager import Snap.Snaplet.Auth.Handlers import Snap.Snaplet.Auth.Types import Snap.Snaplet.Heist +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif ------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ -- | Add all standard auth splices to a Heist-enabled application. -- -- This adds the following splices: -- \ -- \ +-- \ addAuthSplices :: HasHeist b - => Lens b (Snaplet (AuthManager b)) - -- ^ A lens reference to 'AuthManager' + => Snaplet (Heist b) + -> SnapletLens b (AuthManager b) + -- ^ A lens reference to 'AuthManager' -> Initializer b v () -addAuthSplices auth = addSplices - [ ("ifLoggedIn", ifLoggedIn auth) - , ("ifLoggedOut", ifLoggedOut auth) - , ("loggedInUser", loggedInUser auth) - ] +addAuthSplices h auth = addConfig h sc + where + sc = mempty & scInterpretedSplices .~ is + & scCompiledSplices .~ cs + is = do + "ifLoggedIn" ## ifLoggedIn auth + "ifLoggedOut" ## ifLoggedOut auth + "loggedInUser" ## loggedInUser auth + cs = compiledAuthSplices auth + ------------------------------------------------------------------------------ +-- | List containing compiled splices for ifLoggedIn, ifLoggedOut, and +-- loggedInUser. +compiledAuthSplices :: SnapletLens b (AuthManager b) + -> Splices (SnapletCSplice b) +compiledAuthSplices auth = do + "ifLoggedIn" ## cIfLoggedIn auth + "ifLoggedOut" ## cIfLoggedOut auth + "loggedInUser" ## cLoggedInUser auth + + +------------------------------------------------------------------------------ +-- | Function to generate interpreted splices from an AuthUser. +userISplices :: Monad m => AuthUser -> Splices (I.Splice m) +userISplices AuthUser{..} = do + "userId" ## I.textSplice $ maybe "-" unUid userId + "userLogin" ## I.textSplice userLogin + "userEmail" ## I.textSplice $ fromMaybe "-" userEmail + "userActive" ## I.textSplice $ T.pack $ show $ isNothing userSuspendedAt + "userLoginCount" ## I.textSplice $ T.pack $ show userLoginCount + "userFailedCount" ## I.textSplice $ T.pack $ show userFailedLoginCount + "userLoginAt" ## I.textSplice $ maybe "-" (T.pack . show) userCurrentLoginAt + "userLastLoginAt" ## I.textSplice $ maybe "-" (T.pack . show) userLastLoginAt + "userSuspendedAt" ## I.textSplice $ maybe "-" (T.pack . show) userSuspendedAt + "userLoginIP" ## I.textSplice $ maybe "-" decodeUtf8 userCurrentLoginIp + "userLastLoginIP" ## I.textSplice $ maybe "-" decodeUtf8 userLastLoginIp + "userIfActive" ## ifISplice $ isNothing userSuspendedAt + "userIfSuspended" ## ifISplice $ isJust userSuspendedAt + + +------------------------------------------------------------------------------ +-- | Compiled splices for AuthUser. +userCSplices :: Monad m => Splices (RuntimeSplice m AuthUser -> C.Splice m) +userCSplices = fields `mappend` ifs + where + fields = mapV (C.pureSplice . C.textSplice) $ do + "userId" ## maybe "-" unUid . userId + "userLogin" ## userLogin + "userEmail" ## fromMaybe "-" . userEmail + "userActive" ## T.pack . show . isNothing . userSuspendedAt + "userLoginCount" ## T.pack . show . userLoginCount + "userFailedCount" ## T.pack . show . userFailedLoginCount + "userLoginAt" ## maybe "-" (T.pack . show) . userCurrentLoginAt + "userLastLoginAt" ## maybe "-" (T.pack . show) . userLastLoginAt + "userSuspendedAt" ## maybe "-" (T.pack . show) . userSuspendedAt + "userLoginIP" ## maybe "-" decodeUtf8 . userCurrentLoginIp + "userLastLoginIP" ## maybe "-" decodeUtf8 . userLastLoginIp + ifs = do + "userIfActive" ## ifCSplice (isNothing . userSuspendedAt) + "userIfSuspended" ## ifCSplice (isJust . userSuspendedAt) + + +------------------------------------------------------------------------------ -- | A splice that can be used to check for existence of a user. If a user is -- present, this will run the contents of the node. -- -- > Show this when there is a logged in user -ifLoggedIn :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v +ifLoggedIn :: SnapletLens b (AuthManager b) -> SnapletISplice b ifLoggedIn auth = do - chk <- liftHandler $ withTop auth isLoggedIn - case chk of - True -> liftHeist $ getParamNode >>= return . X.childNodes - False -> return [] + chk <- lift $ withTop auth isLoggedIn + case chk of + True -> getParamNode >>= return . X.childNodes + False -> return [] ------------------------------------------------------------------------------ +-- | A splice that can be used to check for existence of a user. If a user is +-- present, this will run the contents of the node. +-- +-- > 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 :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v +ifLoggedOut :: SnapletLens b (AuthManager b) -> SnapletISplice b ifLoggedOut auth = do - chk <- liftHandler $ withTop auth isLoggedIn - case chk of - False -> liftHeist $ getParamNode >>= return . X.childNodes - True -> return [] + chk <- lift $ withTop auth isLoggedIn + case chk of + False -> getParamNode >>= return . X.childNodes + True -> return [] +------------------------------------------------------------------------------ +-- | A splice that can be used to check for absence of a user. If a user is +-- not present, this will run the contents of the node. +-- +-- > 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 :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v +loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b loggedInUser auth = do - u <- liftHandler $ withTop auth currentUser - liftHeist $ maybe (return []) (textSplice . userLogin) u + u <- lift $ withTop auth currentUser + maybe (return []) (I.textSplice . userLogin) u + + +------------------------------------------------------------------------------- +-- | A splice that will simply print the current user's login, if +-- there is one. +cLoggedInUser :: SnapletLens b (AuthManager b) -> SnapletCSplice b +cLoggedInUser auth = + return $ C.yieldRuntimeText $ do + u <- lift $ withTop auth currentUser + return $ maybe "" userLogin u diff --git a/src/Snap/Snaplet/Auth/Types.hs b/src/Snap/Snaplet/Auth/Types.hs --- a/src/Snap/Snaplet/Auth/Types.hs +++ b/src/Snap/Snaplet/Auth/Types.hs @@ -1,16 +1,15 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} module Snap.Snaplet.Auth.Types where ------------------------------------------------------------------------------ -import Control.Applicative import Control.Arrow -import Control.Monad.CatchIO import Control.Monad.Trans -import Control.Monad.Trans.Error import Crypto.PasswordStore import Data.Aeson import Data.ByteString (ByteString) @@ -20,10 +19,15 @@ import Data.Hashable (Hashable) import Data.Time import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Typeable import Snap.Snaplet +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + ------------------------------------------------------------------------------ -- | Password is clear when supplied by the user and encrypted later when -- returned from the db. @@ -77,18 +81,30 @@ -- They may provide useful information to the developer, although it is -- generally not advisable to show the user the exact details about why login -- failed. -data AuthFailure = UserNotFound +data AuthFailure = AuthError String + | BackendError + | DuplicateLogin + | EncryptedPassword | IncorrectPassword - | PasswordMissing | LockedOut UTCTime -- ^ Locked out until given time - | AuthError String - deriving (Read, Show, Ord, Eq, Typeable) + | PasswordMissing + | UsernameMissing + | UserNotFound + deriving (Read, Ord, Eq, Typeable) -instance Exception AuthFailure -instance Error AuthFailure where - strMsg = AuthError +instance Show AuthFailure where + show (AuthError s) = s + show (BackendError) = "Failed to store data in the backend." + show (DuplicateLogin) = "This login already exists in the backend." + show (EncryptedPassword) = "Cannot login with encrypted password." + show (IncorrectPassword) = "The password provided was not valid." + show (LockedOut time) = "The login is locked out until " ++ show time + show (PasswordMissing) = "No password provided." + show (UsernameMissing) = "No username provided." + show (UserNotFound) = "User not found in the backend." + ------------------------------------------------------------------------------ -- | Internal representation of a 'User'. By convention, we demand that the -- application is able to directly fetch a 'User' using this identifier. @@ -98,6 +114,10 @@ newtype UserId = UserId { unUid :: Text } deriving ( Read, Show, Ord, Eq, FromJSON, ToJSON, Hashable ) +#if MIN_VERSION_aeson(1,0,0) +deriving instance FromJSONKey UserId +deriving instance ToJSONKey UserId +#endif ------------------------------------------------------------------------------ -- | This will be replaced by a role-based permission system. @@ -110,6 +130,10 @@ data AuthUser = AuthUser { userId :: Maybe UserId , userLogin :: Text + + -- We have to have an email field for password reset functionality, but we + -- don't want to force users to log in with their email address. + , userEmail :: Maybe Text , userPassword :: Maybe Password , userActivatedAt :: Maybe UTCTime , userSuspendedAt :: Maybe UTCTime @@ -123,6 +147,8 @@ , userLastLoginIp :: Maybe ByteString , userCreatedAt :: Maybe UTCTime , userUpdatedAt :: Maybe UTCTime + , userResetToken :: Maybe Text + , userResetRequestedAt :: Maybe UTCTime , userRoles :: [Role] , userMeta :: HashMap Text Value } @@ -135,6 +161,7 @@ defAuthUser = AuthUser { userId = Nothing , userLogin = "" + , userEmail = Nothing , userPassword = Nothing , userActivatedAt = Nothing , userSuspendedAt = Nothing @@ -148,6 +175,8 @@ , userLastLoginIp = Nothing , userCreatedAt = Nothing , userUpdatedAt = Nothing + , userResetToken = Nothing + , userResetRequestedAt = Nothing , userRoles = [] , userMeta = HM.empty } @@ -163,23 +192,23 @@ ------------------------------------------------------------------------------ --- | Authetication settings defined at initialization time +-- | Authentication settings defined at initialization time data AuthSettings = AuthSettings { asMinPasswdLen :: Int - -- ^ Currently not used/checked + -- ^ Currently not used/checked , asRememberCookieName :: ByteString - -- ^ Name of the desired remember cookie + -- ^ Name of the desired remember cookie , asRememberPeriod :: Maybe Int - -- ^ How long to remember when the option is used in rest of the API. + -- ^ How long to remember when the option is used in rest of the API. -- 'Nothing' means remember until end of session. , asLockout :: Maybe (Int, NominalDiffTime) - -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration]) + -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration]) , asSiteKey :: FilePath - -- ^ Location of app's encryption key + -- ^ Location of app's encryption key } @@ -230,14 +259,6 @@ return $ (pw . rc . rp . lo . sk) defAuthSettings ------------------------------------------------------------------------------- -data BackendError = DuplicateLogin - | BackendError String - deriving (Eq,Show,Read,Typeable) - -instance Exception BackendError - - -------------------- -- JSON Instances -- -------------------- @@ -247,6 +268,7 @@ toJSON u = object [ "uid" .= userId u , "login" .= userLogin u + , "email" .= userEmail u , "pw" .= userPassword u , "activated_at" .= userActivatedAt u , "suspended_at" .= userSuspendedAt u @@ -256,10 +278,12 @@ , "locked_until" .= userLockedOutUntil u , "current_login_at" .= userCurrentLoginAt u , "last_login_at" .= userLastLoginAt u - , "current_ip" .= userCurrentLoginIp u - , "last_ip" .= userLastLoginIp u + , "current_ip" .= fmap decodeUtf8 (userCurrentLoginIp u) + , "last_ip" .= fmap decodeUtf8 (userLastLoginIp u) , "created_at" .= userCreatedAt u , "updated_at" .= userUpdatedAt u + , "reset_token" .= userResetToken u + , "reset_requested_at" .= userResetRequestedAt u , "roles" .= userRoles u , "meta" .= userMeta u ] @@ -270,6 +294,7 @@ parseJSON (Object v) = AuthUser <$> v .: "uid" <*> v .: "login" + <*> v .: "email" <*> v .: "pw" <*> v .: "activated_at" <*> v .: "suspended_at" @@ -279,10 +304,12 @@ <*> v .: "locked_until" <*> v .: "current_login_at" <*> v .: "last_login_at" - <*> v .: "current_ip" - <*> v .: "last_ip" + <*> fmap (fmap encodeUtf8) (v .: "current_ip") + <*> fmap (fmap encodeUtf8) (v .: "last_ip") <*> v .: "created_at" <*> v .: "updated_at" + <*> v .: "reset_token" + <*> v .: "reset_requested_at" <*> v .:? "roles" .!= [] <*> v .: "meta" parseJSON _ = error "Unexpected JSON input" @@ -290,21 +317,21 @@ ------------------------------------------------------------------------------ instance ToJSON Password where - toJSON (Encrypted x) = toJSON x + toJSON (Encrypted x) = toJSON $ decodeUtf8 x toJSON (ClearText _) = error "ClearText passwords can't be serialized into JSON" ------------------------------------------------------------------------------ instance FromJSON Password where - parseJSON = fmap Encrypted . parseJSON + parseJSON = fmap (Encrypted . encodeUtf8) . parseJSON ------------------------------------------------------------------------------ instance ToJSON Role where - toJSON (Role x) = toJSON x + toJSON (Role x) = toJSON $ decodeUtf8 x ------------------------------------------------------------------------------ instance FromJSON Role where - parseJSON = fmap Role . parseJSON + parseJSON = fmap (Role . encodeUtf8) . parseJSON 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 --- a/src/Snap/Snaplet/Heist.hs +++ b/src/Snap/Snaplet/Heist.hs @@ -13,14 +13,29 @@ -- $initializerSection , heistInit , heistInit' + , Unclassed.heistReloader + , Unclassed.setInterpreted + , Unclassed.getCurHeistConfig , addTemplates , addTemplatesAt - , modifyHeistTS - , withHeistTS - , addSplices + , Unclassed.addConfig + , getHeistState + , modifyHeistState + , withHeistState -- * Handler Functions -- $handlerSection + , gRender + , gRenderAs + , gHeistServe + , gHeistServeSingle + , chooseMode + + , cRender + , cRenderAs + , cHeistServe + , cHeistServeSingle + , render , renderAs , heistServe @@ -32,27 +47,22 @@ -- * Writing Splices -- $spliceSection , Unclassed.SnapletHeist - , Unclassed.SnapletSplice - , Unclassed.liftHeist - , Unclassed.liftHandler - , Unclassed.liftAppHandler - , Unclassed.liftWith - , Unclassed.bindSnapletSplices + , Unclassed.SnapletCSplice + , Unclassed.SnapletISplice , clearHeistCache ) where ------------------------------------------------------------------------------ import Prelude hiding (id, (.)) +import Control.Monad.State import Data.ByteString (ByteString) -import Data.Lens.Lazy -import Data.Text (Text) -import Text.Templating.Heist +import Heist ------------------------------------------------------------------------------ import Snap.Snaplet +import Snap.Snaplet.Heist.Internal import qualified Snap.Snaplet.HeistNoClass as Unclassed -import Snap.Snaplet.HeistNoClass ( Heist - , heistInit +import Snap.Snaplet.HeistNoClass ( heistInit , heistInit' , clearHeistCache ) @@ -65,18 +75,18 @@ -- how the heist snaplet might be declared: -- -- > data App = App { _heist :: Snaplet (Heist App) } --- > mkLabels [''App] +-- > makeLenses ''App -- > -- > instance HasHeist App where heistLens = subSnaplet heist -- > -- > appInit = makeSnaplet "app" "" Nothing $ do -- > h <- nestSnaplet "heist" heist $ heistInit "templates" --- > addSplices myAppSplices +-- > addConfig h heistConfigWithMyAppSplices -- > return $ App h class HasHeist b where -- | A lens to the Heist snaplet. The b parameter to Heist will -- typically be the base state of your application. - heistLens :: Lens (Snaplet b) (Snaplet (Heist b)) + heistLens :: SnapletLens (Snaplet b) (Heist b) -- $initializerSection @@ -89,10 +99,11 @@ -- this function to add their own templates. The templates are automatically -- read from the templates directory in the current snaplet's filesystem root. addTemplates :: HasHeist b - => ByteString - -- ^ The url prefix for the template routes + => Snaplet (Heist b) + -> ByteString + -- ^ The url prefix for the template routes -> Initializer b v () -addTemplates pfx = withTop' heistLens (Unclassed.addTemplates pfx) +addTemplates h pfx = withTop' heistLens (Unclassed.addTemplates h pfx) ------------------------------------------------------------------------------ @@ -103,54 +114,150 @@ -- getSnapletFilePath if you want your snaplet to use templates within its -- normal directory structure. addTemplatesAt :: HasHeist b - => ByteString - -- ^ URL prefix for template routes + => Snaplet (Heist b) + -> ByteString + -- ^ URL prefix for template routes -> FilePath - -- ^ Path to templates + -- ^ Path to templates -> Initializer b v () -addTemplatesAt pfx p = withTop' heistLens (Unclassed.addTemplatesAt pfx p) +addTemplatesAt h pfx p = + withTop' heistLens (Unclassed.addTemplatesAt h pfx p) ------------------------------------------------------------------------------ --- | Allows snaplets to add splices. -addSplices :: (HasHeist b) - => [(Text, Unclassed.SnapletSplice b v)] - -- ^ Splices to bind - -> Initializer b v () -addSplices = Unclassed.addSplices' heistLens +-- | More general function allowing arbitrary HeistState modification. +getHeistState :: (HasHeist b) + => Handler b v (HeistState (Handler b b)) +getHeistState = Unclassed.getHeistState heistLens ------------------------------------------------------------------------------ -- | More general function allowing arbitrary HeistState modification. --- Without this function you wouldn't be able to bind more complicated splices --- like the cache tag. -modifyHeistTS :: (HasHeist b) - => (HeistState (Handler b b) -> HeistState (Handler b b)) - -- ^ HeistState modifying function - -> Initializer b v () -modifyHeistTS = Unclassed.modifyHeistTS' heistLens +modifyHeistState :: (HasHeist b) + => (HeistState (Handler b b) -> HeistState (Handler b b)) + -- ^ HeistState modifying function + -> Initializer b v () +modifyHeistState = Unclassed.modifyHeistState' heistLens ------------------------------------------------------------------------------ -- | Runs a function on with the Heist snaplet's 'HeistState'. -withHeistTS :: (HasHeist b) - => (HeistState (Handler b b) -> a) - -- ^ HeistState function to run - -> Handler b v a -withHeistTS = Unclassed.withHeistTS' heistLens +withHeistState :: (HasHeist b) + => (HeistState (Handler b b) -> a) + -- ^ HeistState function to run + -> Handler b v a +withHeistState = Unclassed.withHeistState' heistLens -- $handlerSection -- This section contains functions in the 'Handler' monad that you'll use in --- processing requests. +-- processing requests. Functions beginning with a 'g' prefix use generic +-- rendering that checks the preferred rendering mode and chooses +-- appropriately. Functions beginning with a 'c' prefix use compiled template +-- rendering. The other functions use the older interpreted rendering. +-- Interpreted splices added with addConfig will only work if you use +-- interpreted rendering. +-- +-- The generic functions are useful if you are writing general snaplets that +-- use heist, but need to work for applications that use either interpreted +-- or compiled mode. ------------------------------------------------------------------------------ +-- | Generic version of 'render'/'cRender'. +gRender :: HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +gRender t = withTop' heistLens (Unclassed.gRender t) + + +------------------------------------------------------------------------------ +-- | Generic version of 'renderAs'/'cRenderAs'. +gRenderAs :: HasHeist b + => ByteString + -- ^ Content type to render with + -> ByteString + -- ^ Template name + -> Handler b v () +gRenderAs ct t = withTop' heistLens (Unclassed.gRenderAs ct t) + + +------------------------------------------------------------------------------ +-- | Generic version of 'heistServe'/'cHeistServe'. +gHeistServe :: HasHeist b => Handler b v () +gHeistServe = withTop' heistLens Unclassed.gHeistServe + + +------------------------------------------------------------------------------ +-- | Generic version of 'heistServeSingle'/'cHeistServeSingle'. +gHeistServeSingle :: HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +gHeistServeSingle t = withTop' heistLens (Unclassed.gHeistServeSingle t) + + +------------------------------------------------------------------------------ +-- | Chooses between a compiled action and an interpreted action based on the +-- configured default. +chooseMode :: HasHeist b + => Handler b v a + -- ^ A compiled action + -> Handler b v a + -- ^ An interpreted action + -> Handler b v a +chooseMode cAction iAction = do + mode <- withTop' heistLens $ gets _defMode + case mode of + Unclassed.Compiled -> cAction + Unclassed.Interpreted -> iAction + + +------------------------------------------------------------------------------ +-- | Renders a compiled template as text\/html. If the given template is not +-- found, this returns 'empty'. +cRender :: HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +cRender t = withTop' heistLens (Unclassed.cRender t) + + +------------------------------------------------------------------------------ +-- | Renders a compiled template as the given content type. If the given +-- template is not found, this returns 'empty'. +cRenderAs :: HasHeist b + => ByteString + -- ^ Content type to render with + -> ByteString + -- ^ Template name + -> Handler b v () +cRenderAs ct t = withTop' heistLens (Unclassed.cRenderAs ct t) + + +------------------------------------------------------------------------------ +-- | A compiled version of 'heistServe'. +cHeistServe :: HasHeist b => Handler b v () +cHeistServe = withTop' heistLens Unclassed.cHeistServe + + +------------------------------------------------------------------------------ +-- | Analogous to 'fileServeSingle'. If the given template is not found, +-- this throws an error. +cHeistServeSingle :: HasHeist b + => ByteString + -- ^ Template name + -> Handler b v () +cHeistServeSingle t = withTop' heistLens (Unclassed.cHeistServeSingle t) + + +------------------------------------------------------------------------------ -- | Renders a template as text\/html. If the given template is not found, -- this returns 'empty'. render :: HasHeist b => ByteString - -- ^ Template name + -- ^ Template name -> Handler b v () render t = withTop' heistLens (Unclassed.render t) @@ -160,26 +267,32 @@ -- is not found, this returns 'empty'. renderAs :: HasHeist b => ByteString - -- ^ Content type to render with + -- ^ Content type to render with -> ByteString - -- ^ Template name + -- ^ Template name -> Handler b v () renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t) ------------------------------------------------------------------------------ --- | Analogous to 'fileServe'. If the template specified in the request path --- is not found, it returns 'empty'. +-- | A handler that serves all the templates (similar to 'serveDirectory'). +-- If the template specified in the request path is not found, it returns +-- 'empty'. Also, this function does not serve any templates beginning with +-- an underscore. This gives you a way to prevent some templates from being +-- served. For example, you might have a template that contains only the +-- navbar of your pages, and you probably wouldn't want that template to be +-- visible to the user as a standalone template. So if you put it in a file +-- called \"_nav.tpl\", this function won't serve it. heistServe :: HasHeist b => Handler b v () heistServe = withTop' heistLens Unclassed.heistServe ------------------------------------------------------------------------------ --- | Analogous to 'fileServeSingle'. If the given template is not found, --- this throws an error. +-- | Handler for serving a single template (similar to 'fileServeSingle'). If +-- the given template is not found, this throws an error. heistServeSingle :: HasHeist b => ByteString - -- ^ Template name + -- ^ Template name -> Handler b v () heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t) @@ -189,9 +302,9 @@ -- a common combination of heistLocal, bindSplices, and render. renderWithSplices :: HasHeist b => ByteString - -- ^ Template name - -> [(Text, Unclassed.SnapletSplice b v)] - -- ^ Splices to bind + -- ^ Template name + -> Splices (Unclassed.SnapletISplice b) + -- ^ Splices to bind -> Handler b v () renderWithSplices = Unclassed.renderWithSplices' heistLens @@ -200,10 +313,10 @@ -- | Runs an action with additional splices bound into the Heist -- 'HeistState'. withSplices :: HasHeist b - => [(Text, Unclassed.SnapletSplice b v)] - -- ^ Splices to bind + => Splices (Unclassed.SnapletISplice b) + -- ^ Splices to bind -> Handler b v a - -- ^ Handler to run + -- ^ Handler to run -> Handler b v a withSplices = Unclassed.withSplices' heistLens @@ -216,22 +329,21 @@ -- > heistLocal (bindSplices mySplices) handlerThatNeedsSplices heistLocal :: HasHeist b => (HeistState (Handler b b) -> HeistState (Handler b b)) - -- ^ HeistState modifying function + -- ^ HeistState modifying function -> Handler b v a - -- ^ Handler to run + -- ^ Handler to run -> Handler b v a heistLocal = Unclassed.heistLocal' heistLens -- $spliceSection --- As can be seen in the type signature of heistLocal, the internal --- HeistState used by the heist snaplet is parameterized by (Handler b b). --- The reasons for this are beyond the scope of this discussion, but the --- result is that 'lift' inside a splice only works with @Handler b b@ --- actions. When you're writing your own snaplets you obviously would rather --- work with @Handler b v@ so your local snaplet's state is available. We --- provide the SnapletHeist monad to make this possible. The general rule is --- that when you're using Snaplets and Heist, use SnapletHeist instead of --- HeistT (previously called TemplateMonad) and use SnapletSplice instead of --- Splice. +-- The type signature for SnapletHeist uses @(Handler b b)@ as the Heist +-- snaplet's runtime monad. This means that your splices must use the +-- top-level snaplet's @Handler b b@ monad. The reasons for this are beyond +-- the scope of this discussion, but the result is that 'lift' inside a splice +-- only works with @Handler b b@ actions. When you're writing your own +-- snaplets using some snaplet-specific monad @Handler b v@ you still have to +-- use @Handler b b@ for your splices. If the splices need any of the context +-- provided by the @v@, you must pass it in as a parameter to the splice +-- function. 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 --- a/src/Snap/Snaplet/HeistNoClass.hs +++ b/src/Snap/Snaplet/HeistNoClass.hs @@ -1,23 +1,49 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} + +{-| + +This module implements the Heist snaplet without using type classes. It is +provided mainly as an example of how snaplets can be written with and without +a type class for convenience. + +-} module Snap.Snaplet.HeistNoClass ( Heist + , DefaultMode(..) , heistInit , heistInit' + , heistReloader + , setInterpreted + , getCurHeistConfig , clearHeistCache , addTemplates , addTemplatesAt - , modifyHeistTS - , modifyHeistTS' - , withHeistTS - , withHeistTS' - , addSplices - , addSplices' + , getHeistState + , modifyHeistState + , modifyHeistState' + , withHeistState + , withHeistState' + + , gRender + , gRenderAs + , gHeistServe + , gHeistServeSingle + , chooseMode + + , addConfig + , cRender + , cRenderAs + , cHeistServe + , cHeistServeSingle + , render , renderAs , heistServe @@ -30,63 +56,53 @@ , renderWithSplices' , SnapletHeist - , SnapletSplice - , runSnapletSplice - , liftHeist - , liftWith - , liftHandler - , liftAppHandler - , bindSnapletSplices + , SnapletISplice + , SnapletCSplice ) where import Prelude hiding ((.), id) -import Control.Arrow import Control.Applicative import Control.Category -import Control.Monad.CatchIO (MonadCatchIO) +import Control.Lens import Control.Monad.Reader import Control.Monad.State import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.UTF8 as U +import Data.DList (DList) +import qualified Data.HashMap.Strict as Map +import Data.IORef import Data.Maybe -import Data.Monoid -import Data.Lens.Lazy -import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding import System.FilePath.Posix -import Text.Templating.Heist -import Text.Templating.Heist.Splices.Cache +import Heist +import qualified Heist.Compiled as C +import qualified Heist.Interpreted as I +import Heist.Splices.Cache +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + import Snap.Snaplet +import Snap.Snaplet.Heist.Internal import Snap.Core import Snap.Util.FileServe ------------------------------------------------------------------------------ --- | The state for the Heist snaplet. To use the Heist snaplet in your app --- include this in your application state and use 'heistInit' to initialize --- it. The type parameter b will typically be the base state type for your --- application. --- -data Heist b = Heist - { _heistTS :: HeistState (Handler b b) - , _heistCTS :: CacheTagState - } - - ------------------------------------------------------------------------------- -changeTS :: (HeistState (Handler a a) -> HeistState (Handler a a)) - -> Heist a - -> Heist a -changeTS f (Heist ts cts) = Heist (f ts) cts +changeState :: (HeistState (Handler a a) -> HeistState (Handler a a)) + -> Heist a + -> Heist a +changeState _ (Configuring _) = + error "changeState: HeistState has not been initialized" +changeState f (Running hc hs cts dm) = Running hc (f hs) cts dm ------------------------------------------------------------------------------ -- | Clears data stored by the cache tag. The cache tag automatically reloads -- its data when the specified TTL expires, but sometimes you may want to -- trigger a manual reload. This function lets you do that. --- clearHeistCache :: Heist b -> IO () clearHeistCache = clearCacheTagState . _heistCTS @@ -98,262 +114,169 @@ ------------------------------------------------------------------------------ -- | This instance is here because we don't want the heist package to depend -- on anything from snap packages. --- -instance MonadSnap m => MonadSnap (HeistT m) where +instance MonadSnap m => MonadSnap (HeistT n m) where liftSnap = lift . liftSnap ------------------------------------------------------------------------------- --- | Monad for working with Heist's API from within a snaplet. --- -newtype SnapletHeist b v a = SnapletHeist - (ReaderT (Lens (Snaplet b) (Snaplet v)) (HeistT (Handler b b)) a) - deriving ( Monad - , Functor - , Applicative - , Alternative - , MonadIO - , MonadPlus - , MonadReader (Lens (Snaplet b) (Snaplet v)) - , MonadCatchIO - , MonadSnap - ) - - ------------------------------------------------------------------------------- --- | Type alias for convenience. --- -type SnapletSplice b v = SnapletHeist b v Template - - ------------------------------------------------------------------------------- --- | Runs the SnapletSplice. --- -runSnapletSplice :: (Lens (Snaplet b) (Snaplet v)) - -> SnapletHeist b v a - -> HeistT (Handler b b) a -runSnapletSplice l (SnapletHeist m) = runReaderT m l - - ------------------------------------------------------------------------------- -withSS :: (Lens (Snaplet b) (Snaplet v) -> Lens (Snaplet b) (Snaplet v')) - -> SnapletHeist b v' a - -> SnapletHeist b v a -withSS f (SnapletHeist m) = SnapletHeist $ withReaderT f m - - ------------------------------------------------------------------------------- --- | Lifts a HeistT action into SnapletHeist. Use this with all the functions --- from the Heist API. --- -liftHeist :: HeistT (Handler b b) a -> SnapletHeist b v a -liftHeist = SnapletHeist . lift - - ------------------------------------------------------------------------------- --- | Common idiom for the combination of liftHandler and withTop. --- -liftWith :: (Lens (Snaplet b) (Snaplet v')) - -> Handler b v' a - -> SnapletHeist b v a -liftWith l = liftHeist . lift . withTop' l - - ------------------------------------------------------------------------------- --- | Lifts a Handler into SnapletHeist. --- -liftHandler :: Handler b v a -> SnapletHeist b v a -liftHandler m = do - l <- ask - liftWith l m - - ------------------------------------------------------------------------------- --- | Lifts a (Handler b b) into SnapletHeist. --- -liftAppHandler :: Handler b b a -> SnapletHeist b v a -liftAppHandler = liftHeist . lift - - ------------------------------------------------------------------------------- -instance MonadState v (SnapletHeist b v) where - get = do - l <- ask - b <- liftAppHandler getSnapletState - return $ getL (snapletValue . l) b - put s = do - l <- ask - b <- liftAppHandler getSnapletState - liftAppHandler $ putSnapletState $ setL (snapletValue . l) s b - - ------------------------------------------------------------------------------- --- | MonadSnaplet instance gives us access to the snaplet infrastructure. --- -instance MonadSnaplet SnapletHeist where - getLens = ask - with' l = withSS (l .) - withTop' l = withSS (const id) . with' l - getOpaqueConfig = do - l <- ask - b <- liftAppHandler getSnapletState - return $ getL (snapletConfig . l) b - - ------------------------------------------------------------------------------- --- | SnapletSplices version of bindSplices. --- -bindSnapletSplices :: (Lens (Snaplet b) (Snaplet v)) - -> [(Text, SnapletSplice b v)] - -> HeistState (Handler b b) - -> HeistState (Handler b b) -bindSnapletSplices l splices = - bindSplices $ map (second $ runSnapletSplice l) splices +type SnapletHeist b m a = HeistT (Handler b b) m a +type SnapletCSplice b = SnapletHeist b IO (DList (Chunk (Handler b b))) +type SnapletISplice b = SnapletHeist b (Handler b b) Template --------------------------- -- Initializer functions -- --------------------------- + ------------------------------------------------------------------------------ -- | The 'Initializer' for 'Heist'. This function is a convenience wrapper --- around `heistInit'` that uses the default `mempty` HeistState and sets up --- routes for all the templates. --- -heistInit :: FilePath -- ^ Path to templates +-- around `heistInit'` that uses defaultHeistState and sets up routes for all +-- the templates. It sets up a \"heistReload\" route that reloads the heist +-- templates when you request it from localhost. +heistInit :: FilePath + -- ^ Path to templates -> SnapletInit b (Heist b) -heistInit templateDir = do - makeSnaplet "heist" "" Nothing $ do - hs <- heistInitWorker templateDir defaultHeistState - addRoutes [ ("", heistServe) ] - return hs +heistInit = gHeistInit heistServe ------------------------------------------------------------------------------ -- | A lower level 'Initializer' for 'Heist'. This initializer requires you --- to specify the initial HeistState. It also does not add any routes for +-- to specify the initial HeistConfig. It also does not add any routes for -- templates, allowing you complete control over which templates get routed. --- heistInit' :: FilePath - -- ^ Path to templates - -> HeistState (Handler b b) - -- ^ Initial HeistState + -- ^ Path to templates + -> HeistConfig (Handler b b) + -- ^ Initial HeistConfig -> SnapletInit b (Heist b) -heistInit' templateDir initialHeistState = - makeSnaplet "heist" "" Nothing $ - heistInitWorker templateDir initialHeistState +heistInit' templateDir initialConfig = + makeSnaplet "heist" "" Nothing $ heistInitWorker templateDir initialConfig ------------------------------------------------------------------------------ --- | Internal worker function used by variantsof heistInit. This is necessary --- because of the divide between SnapletInit and Initializer. --- -heistInitWorker :: FilePath - -> HeistState (Handler b b) - -> Initializer b v (Heist b) -heistInitWorker templateDir initialHeistState = do - (cacheFunc, cts) <- liftIO mkCacheTag - let origTs = cacheFunc initialHeistState - snapletPath <- getSnapletFilePath - let tDir = snapletPath templateDir - ts <- liftIO $ loadTemplates tDir origTs >>= - either error return - printInfo $ T.pack $ unwords - [ "...loaded" - , (show $ length $ templateNames ts) - , "templates from" - , tDir - ] - - return $ Heist ts cts +-- | Sets the snaplet to default to interpreted mode. Initially, the +-- initializer sets the value to compiled mode. This function allows you to +-- override that setting. Note that this is just a default. It only has an +-- effect if you use one of the generic functions: 'gRender', 'gRenderAs', +-- 'gHeistServe', or 'gHeistServeSingle'. If you call the non-generic +-- versions directly, then this value will not be checked and you will get the +-- mode implemented by the function you called. +setInterpreted :: Snaplet (Heist b) -> Initializer b v () +setInterpreted h = + liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) + (\(hc,_) -> ((hc,Interpreted),())) ------------------------------------------------------------------------------ --- | Adds templates to the Heist HeistState. Other snaplets should use +-- | Adds templates to the Heist HeistConfig. Other snaplets should use -- this function to add their own templates. The templates are automatically -- read from the templates directory in the current snaplet's filesystem root. -addTemplates :: ByteString - -- ^ The url prefix for the template routes +addTemplates :: Snaplet (Heist b) + -> ByteString + -- ^ The url prefix for the template routes -> Initializer b (Heist b) () -addTemplates urlPrefix = do +addTemplates h urlPrefix = do snapletPath <- getSnapletFilePath - addTemplatesAt urlPrefix (snapletPath "templates") + addTemplatesAt h urlPrefix (snapletPath "templates") ------------------------------------------------------------------------------ --- | Adds templates to the Heist HeistState, and lets you specify where +-- | Adds templates to the Heist HeistConfig, and lets you specify where -- they are found in the filesystem. Note that the path to the template -- directory is an absolute path. This allows you more flexibility in where -- your templates are located, but means that you have to explicitly call -- getSnapletFilePath if you want your snaplet to use templates within its -- normal directory structure. -addTemplatesAt :: ByteString - -- ^ URL prefix for template routes +addTemplatesAt :: Snaplet (Heist b) + -> ByteString + -- ^ URL prefix for template routes -> FilePath - -- ^ Path to templates + -- ^ Path to templates -> Initializer b (Heist b) () -addTemplatesAt urlPrefix templateDir = do - ts <- liftIO $ loadTemplates templateDir mempty - >>= either error return +addTemplatesAt h urlPrefix templateDir = do rootUrl <- getSnapletRootURL - let fullPrefix = U.toString rootUrl U.toString urlPrefix + let fullPrefix = (T.unpack $ decodeUtf8 rootUrl) + (T.unpack $ decodeUtf8 urlPrefix) + addPrefix = addTemplatePathPrefix + (encodeUtf8 $ T.pack fullPrefix) + ts <- liftIO $ (loadTemplates templateDir) >>= + either (error . concat) return printInfo $ T.pack $ unwords [ "...adding" - , (show $ length $ templateNames ts) + , (show $ Map.size ts) , "templates from" , templateDir , "with route prefix" , fullPrefix ++ "/" ] - addPostInitHook $ return . changeTS - (`mappend` addTemplatePathPrefix (U.fromString fullPrefix) ts) + let locations = [fmap addPrefix <$> loadTemplates templateDir] + add (hc, dm) = + ((over hcTemplateLocations (mappend locations) hc, dm), ()) + liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) add +getCurHeistConfig :: Snaplet (Heist b) + -> Initializer b v (HeistConfig (Handler b b)) +getCurHeistConfig h = case view snapletValue h of + Configuring ref -> do + (hc, _) <- liftIO $ readIORef ref + return hc + Running _ _ _ _ -> + error "Can't get HeistConfig after heist is initialized." + + ------------------------------------------------------------------------------ -modifyHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b))) - -> (HeistState (Handler b b) -> HeistState (Handler b b)) - -> Initializer b v () -modifyHeistTS' heist f = do - _lens <- getLens - withTop' heist $ addPostInitHook $ return . changeTS f +getHeistState :: SnapletLens (Snaplet b) (Heist b) + -> Handler b v (HeistState (Handler b b)) +getHeistState heist = withTop' heist $ gets _heistState ------------------------------------------------------------------------------ -modifyHeistTS :: (Lens b (Snaplet (Heist b))) - -> (HeistState (Handler b b) -> HeistState (Handler b b)) - -> Initializer b v () -modifyHeistTS heist f = modifyHeistTS' (subSnaplet heist) f +modifyHeistState' :: SnapletLens (Snaplet b) (Heist b) + -> (HeistState (Handler b b) -> HeistState (Handler b b)) + -> Initializer b v () +modifyHeistState' heist f = do + withTop' heist $ addPostInitHook $ return . Right . changeState f ------------------------------------------------------------------------------ -withHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b))) - -> (HeistState (Handler b b) -> a) - -> Handler b v a -withHeistTS' heist f = withTop' heist $ gets (f . _heistTS) +modifyHeistState :: SnapletLens b (Heist b) + -> (HeistState (Handler b b) -> HeistState (Handler b b)) + -> Initializer b v () +modifyHeistState heist f = modifyHeistState' (subSnaplet heist) f ------------------------------------------------------------------------------ -withHeistTS :: (Lens b (Snaplet (Heist b))) - -> (HeistState (Handler b b) -> a) - -> Handler b v a -withHeistTS heist f = withHeistTS' (subSnaplet heist) f +withHeistState' :: SnapletLens (Snaplet b) (Heist b) + -> (HeistState (Handler b b) -> a) + -> Handler b v a +withHeistState' heist f = do + hs <- withTop' heist $ gets _heistState + return $ f hs ------------------------------------------------------------------------------ -addSplices' :: (Lens (Snaplet b) (Snaplet (Heist b))) - -> [(Text, SnapletSplice b v)] - -> Initializer b v () -addSplices' heist splices = do - _lens <- getLens - withTop' heist $ addPostInitHook $ - return . changeTS (bindSnapletSplices _lens splices) +withHeistState :: SnapletLens b (Heist b) + -> (HeistState (Handler b b) -> a) + -> Handler b v a +withHeistState heist f = withHeistState' (subSnaplet heist) f ------------------------------------------------------------------------------ -addSplices :: (Lens b (Snaplet (Heist b))) - -> [(Text, SnapletSplice b v)] - -> Initializer b v () -addSplices heist splices = addSplices' (subSnaplet heist) splices +-- | Adds more HeistConfig data using mappend with whatever is currently +-- there. This is the preferred method for adding all four kinds of splices +-- as well as new templates. +addConfig :: Snaplet (Heist b) + -> SpliceConfig (Handler b b) + -> Initializer b v () +addConfig h sc = case view snapletValue h of + Configuring ref -> + liftIO $ atomicModifyIORef ref add + Running _ _ _ _ -> do + printInfo "finalLoadHook called while running" + error "this shouldn't happen" + where + add (hc, dm) = + ((over hcSpliceConfig (`mappend` sc) hc, dm), ()) ----------------------- @@ -362,12 +285,12 @@ ------------------------------------------------------------------------------ -- | Internal helper function for rendering. -renderHelper :: Maybe MIMEType +iRenderHelper :: Maybe MIMEType -> ByteString -> Handler b (Heist b) () -renderHelper c t = do - (Heist ts _) <- get - withTop' id $ renderTemplate ts t >>= maybe pass serve +iRenderHelper c t = do + (Running _ hs _ _) <- get + withTop' id $ I.renderTemplate hs t >>= maybe pass serve where serve (b, mime) = do modifyResponse $ setContentType $ fromMaybe mime c @@ -375,49 +298,149 @@ ------------------------------------------------------------------------------ +-- | Internal helper function for rendering. +cRenderHelper :: Maybe MIMEType + -> ByteString + -> Handler b (Heist b) () +cRenderHelper c t = do + (Running _ hs _ _) <- get + withTop' id $ maybe pass serve $ C.renderTemplate hs t + where + serve (b, mime) = do + modifyResponse $ setContentType $ fromMaybe mime c + writeBuilder =<< b + + +------------------------------------------------------------------------------ +serveURI :: Handler b (Heist b) ByteString +serveURI = do + p <- getSafePath + -- Allows users to prefix template filenames with an underscore to prevent + -- the template from being served. + if take 1 p == "_" then pass else return $ B.pack p + + +------------------------------------------------------------------------------ render :: ByteString - -- ^ Name of the template + -- ^ Name of the template -> Handler b (Heist b) () -render t = renderHelper Nothing t +render t = iRenderHelper Nothing t ------------------------------------------------------------------------------ renderAs :: ByteString - -- ^ Content type + -- ^ Content type -> ByteString - -- ^ Name of the template + -- ^ Name of the template -> Handler b (Heist b) () -renderAs ct t = renderHelper (Just ct) t +renderAs ct t = iRenderHelper (Just ct) t ------------------------------------------------------------------------------ heistServe :: Handler b (Heist b) () heistServe = - ifTop (render "index") <|> (render . B.pack =<< getSafePath) + ifTop (render "index") <|> (render =<< serveURI) ------------------------------------------------------------------------------ -heistServeSingle :: ByteString - -> Handler b (Heist b) () +heistServeSingle :: ByteString -> Handler b (Heist b) () heistServeSingle t = render t <|> error ("Template " ++ show t ++ " not found.") ------------------------------------------------------------------------------ -heistLocal' :: (Lens (Snaplet b) (Snaplet (Heist b))) +cRender :: ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +cRender t = cRenderHelper Nothing t + + +------------------------------------------------------------------------------ +cRenderAs :: ByteString + -- ^ Content type + -> ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +cRenderAs ct t = cRenderHelper (Just ct) t + + +------------------------------------------------------------------------------ +cHeistServe :: Handler b (Heist b) () +cHeistServe = + ifTop (cRender "index") <|> (cRender =<< serveURI) + + +------------------------------------------------------------------------------ +cHeistServeSingle :: ByteString -> Handler b (Heist b) () +cHeistServeSingle t = + cRender t <|> error ("Template " ++ show t ++ " not found.") + + +------------------------------------------------------------------------------ +-- | Chooses between a compiled action and an interpreted action based on the +-- configured default. +chooseMode :: MonadState (Heist b1) m + => m b + -- ^ A compiled action + -> m b + -- ^ An interpreted action + -> m b +chooseMode cAction iAction = do + mode <- gets _defMode + case mode of + Compiled -> cAction + Interpreted -> iAction + + +------------------------------------------------------------------------------ +-- | Like render/cRender, but chooses between the two appropriately based on +-- the default mode. +gRender :: ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +gRender t = chooseMode (cRender t) (render t) + + +------------------------------------------------------------------------------ +-- | Like renderAs/cRenderAs, but chooses between the two appropriately based +-- on the default mode. +gRenderAs :: ByteString + -- ^ Content type + -> ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +gRenderAs ct t = chooseMode (cRenderAs ct t) (renderAs ct t) + + +------------------------------------------------------------------------------ +-- | Like heistServe/cHeistServe, but chooses between the two appropriately +-- based on the default mode. +gHeistServe :: Handler b (Heist b) () +gHeistServe = chooseMode cHeistServe heistServe + + +------------------------------------------------------------------------------ +-- | Like heistServeSingle/cHeistServeSingle, but chooses between the two +-- appropriately based on the default mode. +gHeistServeSingle :: ByteString -> Handler b (Heist b) () +gHeistServeSingle t = chooseMode (cHeistServeSingle t) (heistServeSingle t) + + +------------------------------------------------------------------------------ +heistLocal' :: SnapletLens (Snaplet b) (Heist b) -> (HeistState (Handler b b) -> HeistState (Handler b b)) -> Handler b v a -> Handler b v a heistLocal' heist f m = do hs <- withTop' heist get - withTop' heist $ modify $ changeTS f + withTop' heist $ modify $ changeState f res <- m withTop' heist $ put hs return res ------------------------------------------------------------------------------ -heistLocal :: (Lens b (Snaplet (Heist b))) +heistLocal :: SnapletLens b (Heist b) -> (HeistState (Handler b b) -> HeistState (Handler b b)) -> Handler b v a -> Handler b v a @@ -425,38 +448,35 @@ ------------------------------------------------------------------------------ -withSplices' :: (Lens (Snaplet b) (Snaplet (Heist b))) - -> [(Text, SnapletSplice b v)] +withSplices' :: SnapletLens (Snaplet b) (Heist b) + -> Splices (SnapletISplice b) -> Handler b v a -> Handler b v a withSplices' heist splices m = do - _lens <- getLens - heistLocal' heist (bindSnapletSplices _lens splices) m + heistLocal' heist (I.bindSplices splices) m ------------------------------------------------------------------------------ -withSplices :: (Lens b (Snaplet (Heist b))) - -> [(Text, SnapletSplice b v)] +withSplices :: SnapletLens b (Heist b) + -> Splices (SnapletISplice b) -> Handler b v a -> Handler b v a withSplices heist splices m = withSplices' (subSnaplet heist) splices m ------------------------------------------------------------------------------ -renderWithSplices' :: (Lens (Snaplet b) (Snaplet (Heist b))) +renderWithSplices' :: SnapletLens (Snaplet b) (Heist b) -> ByteString - -> [(Text, SnapletSplice b v)] + -> Splices (SnapletISplice b) -> Handler b v () renderWithSplices' heist t splices = withSplices' heist splices $ withTop' heist $ render t ------------------------------------------------------------------------------ -renderWithSplices :: (Lens b (Snaplet (Heist b))) +renderWithSplices :: SnapletLens b (Heist b) -> ByteString - -> [(Text, SnapletSplice b v)] + -> Splices (SnapletISplice b) -> Handler b v () renderWithSplices heist t splices = renderWithSplices' (subSnaplet heist) t splices - - diff --git a/src/Snap/Snaplet/Internal/Initializer.hs b/src/Snap/Snaplet/Internal/Initializer.hs --- a/src/Snap/Snaplet/Internal/Initializer.hs +++ b/src/Snap/Snaplet/Internal/Initializer.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Snap.Snaplet.Internal.Initializer ( addPostInitHook @@ -13,42 +14,70 @@ , nameSnaplet , onUnload , addRoutes - , wrapHandlers + , wrapSite , runInitializer , runSnaplet , combineConfig , serveSnaplet + , serveSnapletNoArgParsing + , loadAppConfig , printInfo + , getRoutes + , getEnvironment + , modifyMaster ) where -import Prelude hiding ((.), id, catch) -import Control.Category -import Control.Concurrent.MVar -import Control.Exception (SomeException) -import Control.Monad -import Control.Monad.CatchIO hiding (Handler) -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Trans.Writer hiding (pass) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Configurator -import Data.IORef -import Data.Maybe -import Data.Lens.Lazy -import Data.Text (Text) -import qualified Data.Text as T -import Snap.Http.Server -import Snap.Core -import Snap.Util.GZip -import System.Directory -import System.Directory.Tree -import System.FilePath.Posix -import System.IO - -import qualified Snap.Snaplet.Internal.LensT as LT +------------------------------------------------------------------------------ +import Control.Applicative ((<$>)) +import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, + putMVar, readMVar) +import Control.Exception.Lifted (SomeException, catch, try) +import Control.Lens (ALens', cloneLens, over, set, + storing, (^#)) +import Control.Monad (Monad (..), join, liftM, unless, + when, (=<<)) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, modify) +import Control.Monad.Trans (lift, liftIO) +import Control.Monad.Trans.Writer hiding (pass) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Configurator (Worth (..), addToConfig, empty, + loadGroups, subconfig) +import qualified Data.Configurator.Types as C +import Data.IORef (IORef, atomicModifyIORef, + newIORef, readIORef) +import Data.Maybe (Maybe (..), fromJust, fromMaybe, + isNothing) +import Data.Text (Text) +import qualified Data.Text as T +import Prelude (Bool (..), Either (..), Eq (..), + String, concat, concatMap, + const, either, + error, filter, flip, fst, id, + map, not, show, ($), ($!), (++), + (.)) +import Snap.Core (Snap, liftSnap, route) +import Snap.Http.Server (Config, completeConfig, + getCompression, getErrorHandler, + getOther, getVerbose, httpServe) +import Snap.Util.GZip (withCompression) +import System.Directory (copyFile, + createDirectoryIfMissing, + doesDirectoryExist, + getCurrentDirectory) +import System.Directory.Tree (DirTree (..), FileName, buildL, + dirTree, readDirectoryWith) +import System.FilePath.Posix (dropFileName, makeRelative, + ()) +import System.IO (FilePath, IO, hPutStrLn, stderr) +------------------------------------------------------------------------------ +import Snap.Snaplet.Config (AppConfig, appEnvironment, + commandLineAppConfig) import qualified Snap.Snaplet.Internal.Lensed as L +import qualified Snap.Snaplet.Internal.LensT as LT import Snap.Snaplet.Internal.Types +------------------------------------------------------------------------------ ------------------------------------------------------------------------------ @@ -74,11 +103,26 @@ ------------------------------------------------------------------------------ +-- | Lets you retrieve the list of routes currently set up by an Initializer. +-- This can be useful in debugging. +getRoutes :: Initializer b v [ByteString] +getRoutes = liftM (map fst) $ iGets _handlers + +------------------------------------------------------------------------------ +-- | Return the current environment string. This will be the +-- environment given to 'runSnaplet' or from the command line when +-- using 'serveSnaplet'. Useful for changing behavior during +-- development and testing. +getEnvironment :: Initializer b v String +getEnvironment = iGets _environment + +------------------------------------------------------------------------------ -- | Converts a plain hook into a Snaplet hook. -toSnapletHook :: (v -> IO v) -> (Snaplet v -> IO (Snaplet v)) -toSnapletHook f (Snaplet cfg val) = do +toSnapletHook :: (v -> IO (Either Text v)) + -> (Snaplet v -> IO (Either Text (Snaplet v))) +toSnapletHook f (Snaplet cfg reset val) = do val' <- f val - return $! Snaplet cfg val' + return $! Snaplet cfg reset <$> val' ------------------------------------------------------------------------------ @@ -89,11 +133,13 @@ -- define its views. The Heist snaplet provides the 'addTemplates' function -- which allows other snaplets to set up their own templates. 'addTemplates' -- is implemented using this function. -addPostInitHook :: (v -> IO v) -> Initializer b v () +addPostInitHook :: (v -> IO (Either Text v)) + -> Initializer b v () addPostInitHook = addPostInitHook' . toSnapletHook -addPostInitHook' :: (Snaplet v -> IO (Snaplet v)) -> Initializer b v () +addPostInitHook' :: (Snaplet v -> IO (Either Text (Snaplet v))) + -> Initializer b v () addPostInitHook' h = do h' <- upHook h addPostInitHookBase h' @@ -101,15 +147,15 @@ ------------------------------------------------------------------------------ -- | Variant of addPostInitHook for when you have things wrapped in a Snaplet. -addPostInitHookBase :: (Snaplet b -> IO (Snaplet b)) +addPostInitHookBase :: (Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v () addPostInitHookBase = Initializer . lift . tell . Hook ------------------------------------------------------------------------------ -- | Helper function for transforming hooks. -upHook :: (Snaplet v -> IO (Snaplet v)) - -> Initializer b v (Snaplet b -> IO (Snaplet b)) +upHook :: (Snaplet v -> IO (Either Text (Snaplet v))) + -> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b))) upHook h = Initializer $ do l <- ask return $ upHook' l h @@ -117,27 +163,29 @@ ------------------------------------------------------------------------------ -- | Helper function for transforming hooks. -upHook' :: (Lens b a) -> (a -> IO a) -> b -> IO b +upHook' :: Monad m => ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b) upHook' l h b = do - v <- h (getL l b) - return $ setL l v b + v <- h (b ^# l) + return $ case v of + Left e -> Left e + Right v' -> Right $ storing l v' b ------------------------------------------------------------------------------ -- | Modifies the Initializer's SnapletConfig. modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v () -modifyCfg f = iModify $ modL curConfig $ \c -> f c +modifyCfg f = iModify $ over curConfig $ \c -> f c ------------------------------------------------------------------------------ -- | If a snaplet has a filesystem presence, this function creates and copies -- the files if they dont' already exist. setupFilesystem :: Maybe (IO FilePath) - -- ^ The directory where the snaplet's reference files are - -- stored. Nothing if the snaplet doesn't come with any files - -- that need to be installed. + -- ^ The directory where the snaplet's reference files are + -- stored. Nothing if the snaplet doesn't come with any + -- files that need to be installed. -> FilePath - -- ^ Directory where the files should be copied. + -- ^ Directory where the files should be copied. -> Initializer b v () setupFilesystem Nothing _ = return () setupFilesystem (Just getSnapletDataDir) targetDir = do @@ -151,10 +199,10 @@ where doCopy srcRoot targetRoot filename = do createDirectoryIfMissing True directory - copyFile filename to + copyFile filename toDir where - to = targetRoot makeRelative srcRoot filename - directory = dropFileName to + toDir = targetRoot makeRelative srcRoot filename + directory = dropFileName toDir ------------------------------------------------------------------------------ @@ -174,32 +222,34 @@ -- and makeSnaplet converts it into an opaque SnapletInit type. This allows -- us to use the type system to ensure that the API is used correctly. makeSnaplet :: Text - -- ^ A default id for this snaplet. This is only used when the - -- end-user has not already set an id using the nameSnaplet function. - -> Text - -- ^ A human readable description of this snaplet. - -> Maybe (IO FilePath) - -- ^ The path to the directory holding the snaplet's reference - -- filesystem content. This will almost always be the directory - -- returned by Cabal's getDataDir command, but it has to be passed in - -- because it is defined in a package-specific import. Setting this - -- value to Nothing doesn't preclude the snaplet from having files in - -- in the filesystem, it just means that they won't be copied there - -- automatically. - -> Initializer b v v - -- ^ Snaplet initializer. - -> SnapletInit b v + -- ^ A default id for this snaplet. This is only used when + -- the end-user has not already set an id using the + -- nameSnaplet function. + -> Text + -- ^ A human readable description of this snaplet. + -> Maybe (IO FilePath) + -- ^ The path to the directory holding the snaplet's reference + -- filesystem content. This will almost always be the + -- directory returned by Cabal's getDataDir command, but it + -- has to be passed in because it is defined in a + -- package-specific import. Setting this value to Nothing + -- doesn't preclude the snaplet from having files in in the + -- filesystem, it just means that they won't be copied there + -- automatically. + -> Initializer b v v + -- ^ Snaplet initializer. + -> SnapletInit b v makeSnaplet snapletId desc getSnapletDataDir m = SnapletInit $ do modifyCfg $ \c -> if isNothing $ _scId c - then setL scId (Just snapletId) c else c + then set scId (Just snapletId) c else c sid <- iGets (T.unpack . fromJust . _scId . _curConfig) topLevel <- iGets _isTopLevel unless topLevel $ do - modifyCfg $ modL scUserConfig (subconfig (T.pack sid)) - modifyCfg $ \c -> setL scFilePath + modifyCfg $ over scUserConfig (subconfig (T.pack sid)) + modifyCfg $ \c -> set scFilePath (_scFilePath c "snaplets" sid) c - iModify (setL isTopLevel False) - modifyCfg $ setL scDescription desc + iModify (set isTopLevel False) + modifyCfg $ set scDescription desc cfg <- iGets _curConfig printInfo $ T.pack $ concat ["Initializing " @@ -209,10 +259,11 @@ ] -- This has to happen here because it needs to be after scFilePath is set - -- up but before snaplet.cfg is read. + -- up but before the config file is read. setupFilesystem getSnapletDataDir (_scFilePath cfg) - let configLocation = _scFilePath cfg "snaplet.cfg" + env <- iGets _environment + let configLocation = _scFilePath cfg (env ++ ".cfg") liftIO $ addToConfig [Optional configLocation] (_scUserConfig cfg) mkSnaplet m @@ -221,13 +272,17 @@ ------------------------------------------------------------------------------ -- | Internal function that gets the SnapletConfig out of the initializer -- state and uses it to create a (Snaplet a). -mkSnaplet :: Initializer b v a -> Initializer b v (Snaplet a) +mkSnaplet :: Initializer b v v -> Initializer b v (Snaplet v) mkSnaplet m = do res <- m cfg <- iGets _curConfig - return $ Snaplet cfg res + setInTop <- iGets masterReloader + l <- getLens + let modifier = setInTop . set (cloneLens l . snapletValue) + return $ Snaplet cfg modifier res + ------------------------------------------------------------------------------ -- | Brackets an initializer computation, restoring curConfig after the -- computation returns. @@ -235,7 +290,7 @@ bracketInit m = do s <- iGet res <- m - iModify (setL curConfig (_curConfig s)) + iModify (set curConfig (_curConfig s)) return res @@ -245,9 +300,9 @@ setupSnapletCall :: ByteString -> Initializer b v () setupSnapletCall rte = do curId <- iGets (fromJust . _scId . _curConfig) - modifyCfg (modL scAncestry (curId:)) - modifyCfg (modL scId (const Nothing)) - unless (B.null rte) $ modifyCfg (modL scRouteContext (rte:)) + modifyCfg (over scAncestry (curId:)) + modifyCfg (over scId (const Nothing)) + unless (B.null rte) $ modifyCfg (over scRouteContext (rte:)) ------------------------------------------------------------------------------ @@ -257,73 +312,86 @@ -- possible for the child snaplet to make use of functionality provided by -- sibling snaplets. nestSnaplet :: ByteString - -- ^ The root url for all the snaplet's routes. An empty string - -- gives the routes the same root as the parent snaplet's routes. - -> (Lens v (Snaplet v1)) - -- ^ Lens identifying the snaplet + -- ^ The root url for all the snaplet's routes. An empty + -- string gives the routes the same root as the parent + -- snaplet's routes. + -> SnapletLens v v1 + -- ^ Lens identifying the snaplet -> SnapletInit b v1 - -- ^ The initializer function for the subsnaplet. + -- ^ The initializer function for the subsnaplet. -> Initializer b v (Snaplet v1) -nestSnaplet rte l (SnapletInit snaplet) = with l $ bracketInit $ do - setupSnapletCall rte - snaplet +nestSnaplet rte l (SnapletInit snaplet) = + with l $ bracketInit $ do + setupSnapletCall rte + snaplet ------------------------------------------------------------------------------ -- | Runs another snaplet's initializer and returns the initialized Snaplet --- value. The difference between this and nestSnaplet is the first type +-- value. The difference between this and 'nestSnaplet' is the first type -- parameter in the third argument. The \"v1 v1\" makes the child snaplet --- think that it is top-level, which means that it will not be able to use --- functionality provided by snaplets included above it in the snaplet tree. --- This strongly isolates the child snaplet, and allows you to eliminate the b --- type variable. The embedded snaplet can still get functionality from other --- snaplets, but only if it nests or embeds the snaplet itself. +-- think that it is the top-level state, which means that it will not be able +-- to use functionality provided by snaplets included above it in the snaplet +-- tree. This strongly isolates the child snaplet, and allows you to eliminate +-- the b type variable. The embedded snaplet can still get functionality +-- from other snaplets, but only if it nests or embeds the snaplet itself. +-- +-- Note that this function does not change where this snaplet is located in +-- the filesystem. The snaplet directory structure convention stays the same. +-- Also, embedSnaplet limits the ways that snaplets can interact, so we +-- usually recommend using nestSnaplet instead. However, we provide this +-- function because sometimes reduced flexibility is useful. In short, if +-- you don't understand what this function does for you from looking at its +-- type, you probably don't want to use it. embedSnaplet :: ByteString - -- ^ The root url for all the snaplet's routes. An empty string - -- gives the routes the same root as the parent snaplet's routes. - -- - -- NOTE: Because of the stronger isolation provided by - -- embedSnaplet, you should be more careful about using an empty - -- string here. - -> (Lens v (Snaplet v1)) - -- ^ Lens identifying the snaplet + -- ^ The root url for all the snaplet's routes. An empty + -- string gives the routes the same root as the parent + -- snaplet's routes. + -- + -- NOTE: Because of the stronger isolation provided by + -- embedSnaplet, you should be more careful about using an + -- empty string here. + -> SnapletLens v v1 + -- ^ Lens identifying the snaplet -> SnapletInit v1 v1 - -- ^ The initializer function for the subsnaplet. + -- ^ The initializer function for the subsnaplet. -> Initializer b v (Snaplet v1) embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do curLens <- getLens setupSnapletCall "" - chroot rte (subSnaplet l . curLens) snaplet + chroot rte (cloneLens curLens . subSnaplet l) snaplet ------------------------------------------------------------------------------ -- | Changes the base state of an initializer. chroot :: ByteString - -> (Lens (Snaplet b) (Snaplet v1)) + -> SnapletLens (Snaplet b) v1 -> Initializer v1 v1 a -> Initializer b v a chroot rte l (Initializer m) = do curState <- iGet + let newSetter f = masterReloader curState (over (cloneLens l) f) ((a,s), (Hook hook)) <- liftIO $ runWriterT $ LT.runLensT m id $ curState { _handlers = [], - _hFilter = id + _hFilter = id, + masterReloader = newSetter } let handler = chrootHandler l $ _hFilter s $ route $ _handlers s - iModify $ modL handlers (++[(rte,handler)]) - . setL cleanup (_cleanup s) + iModify $ over handlers (++[(rte,handler)]) + . set cleanup (_cleanup s) addPostInitHookBase $ upHook' l hook return a ------------------------------------------------------------------------------ -- | Changes the base state of a handler. -chrootHandler :: (Lens (Snaplet v) (Snaplet b')) +chrootHandler :: SnapletLens (Snaplet v) b' -> Handler b' b' a -> Handler b v a chrootHandler l (Handler h) = Handler $ do s <- get - (a, s') <- liftSnap $ L.runLensed h id (getL l s) - modify $ setL l s' + (a, s') <- liftSnap $ L.runLensed h id (s ^# l) + modify $ storing l s' return a @@ -336,12 +404,12 @@ -- -- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@ nameSnaplet :: Text - -- ^ The snaplet name + -- ^ The snaplet name -> SnapletInit b v - -- ^ The snaplet initializer function + -- ^ The snaplet initializer function -> SnapletInit b v nameSnaplet nm (SnapletInit m) = SnapletInit $ - modifyCfg (setL scId (Just nm)) >> m + modifyCfg (set scId (Just nm)) >> m ------------------------------------------------------------------------------ @@ -356,7 +424,7 @@ let modRoute (r,h) = ( buildPath (r:ctx) , setPattern r >> withTop' l h) let rs' = map modRoute rs - iModify (\v -> modL handlers (++rs') v) + iModify (\v -> over handlers (++rs') v) where setPattern r = do p <- getRoutePattern @@ -364,13 +432,20 @@ ------------------------------------------------------------------------------ --- | Wraps the snaplet's routing. This can be used to provide a snaplet that --- does per-request setup and cleanup, but then dispatches to the rest of the --- application. -wrapHandlers :: (Handler b v () -> Handler b v ()) -> Initializer b v () -wrapHandlers f0 = do +-- | Wraps the /base/ snaplet's routing in another handler, allowing you to run +-- code before and after all routes in an application. +-- +-- Here are some examples of things you might do: +-- +-- > wrapSite (\site -> logHandlerStart >> site >> logHandlerFinished) +-- > wrapSite (\site -> ensureAdminUser >> site) +-- +wrapSite :: (Handler b v () -> Handler b v ()) + -- ^ Handler modifier function + -> Initializer b v () +wrapSite f0 = do f <- mungeFilter f0 - iModify (\v -> modL hFilter (f.) v) + iModify (\v -> over hFilter (f.) v) ------------------------------------------------------------------------------ @@ -414,15 +489,18 @@ ------------------------------------------------------------------------------ -- | Builds an IO reload action for storage in the SnapletState. mkReloader :: FilePath - -> MVar (Snaplet b) + -> String + -> ((Snaplet b -> Snaplet b) -> IO ()) + -> IORef (IO ()) -> Initializer b b (Snaplet b) -> IO (Either Text Text) -mkReloader cwd mvar i = do - !res <- runInitializer' mvar i cwd +mkReloader cwd env resetter cleanupRef i = do + join $ readIORef cleanupRef + !res <- runInitializer' resetter env i cwd either (return . Left) good res where good (b,is) = do - _ <- swapMVar mvar b + _ <- resetter (const b) msgs <- readIORef $ _initMessages is return $ Right msgs @@ -439,34 +517,49 @@ ------------------------------------------------------------------------------ +-- | Lets you change a snaplet's initial state. It's almost like a reload, +-- except that it doesn't run the initializer. It just modifies the result of +-- the initializer. This can be used to let you define actions for reloading +-- individual snaplets. +modifyMaster :: v -> Handler b v () +modifyMaster v = do + modifier <- getsSnapletState _snapletModifier + liftIO $ modifier v + + +------------------------------------------------------------------------------ -- | Internal function for running Initializers. If any exceptions were -- thrown by the initializer, this function catches them, runs any cleanup -- actions that had been registered, and returns an expanded error message -- containing the exception details as well as all messages generated by the -- initializer before the exception was thrown. -runInitializer :: MVar (Snaplet b) +runInitializer :: ((Snaplet b -> Snaplet b) -> IO ()) + -> String -> Initializer b b (Snaplet b) -> IO (Either Text (Snaplet b, InitializerState b)) -runInitializer mvar b = getCurrentDirectory >>= runInitializer' mvar b +runInitializer resetter env b = + getCurrentDirectory >>= runInitializer' resetter env b ------------------------------------------------------------------------------ -runInitializer' :: MVar (Snaplet b) +runInitializer' :: ((Snaplet b -> Snaplet b) -> IO ()) + -> String -> Initializer b b (Snaplet b) -> FilePath -> IO (Either Text (Snaplet b, InitializerState b)) -runInitializer' mvar b@(Initializer i) cwd = do +runInitializer' resetter env b@(Initializer i) cwd = do + cleanupRef <- newIORef (return ()) + let reloader_ = mkReloader cwd env resetter cleanupRef b let builtinHandlers = [("/admin/reload", reloadSite)] - let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing - (mkReloader cwd mvar b) + let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing reloader_ logRef <- newIORef "" - cleanupRef <- newIORef (return ()) let body = do ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $ InitializerState True cleanupRef builtinHandlers id cfg logRef + env resetter res' <- hook res - return $ Right (res', s) + return $ (,s) <$> res' handler e = do join $ readIORef cleanupRef @@ -484,18 +577,23 @@ ------------------------------------------------------------------------------ --- | Given a Snaplet initializer, produce the set of messages generated during --- initialization, a snap handler, and a cleanup action. -runSnaplet :: SnapletInit b b -> IO (Text, Snap (), IO ()) -runSnaplet (SnapletInit b) = do +-- | Given an environment and a Snaplet initializer, produce a concatenated log +-- of all messages generated during initialization, a snap handler, and a +-- cleanup action. The environment is an arbitrary string such as \"devel\" or +-- \"production\". This string is used to determine the name of the +-- configuration files used by each snaplet. If an environment of Nothing is +-- used, then runSnaplet defaults to \"devel\". +runSnaplet :: Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ()) +runSnaplet env (SnapletInit b) = do snapletMVar <- newEmptyMVar - eRes <- runInitializer snapletMVar b + let resetter f = modifyMVar_ snapletMVar (return . f) + eRes <- runInitializer resetter (fromMaybe "devel" env) b let go (siteSnaplet,is) = do - putMVar snapletMVar siteSnaplet - msgs <- liftIO $ readIORef $ _initMessages is - let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar - cleanupAction <- readIORef $ _cleanup is - return (msgs, handler, cleanupAction) + putMVar snapletMVar siteSnaplet + msgs <- liftIO $ readIORef $ _initMessages is + let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar + cleanupAction <- readIORef $ _cleanup is + return (msgs, handler, cleanupAction) either (error . ('\n':) . T.unpack) go eRes @@ -516,20 +614,92 @@ ------------------------------------------------------------------------------ --- | Serves a top-level snaplet as a web application. Reads command-line --- arguments. FIXME: document this. -serveSnaplet :: Config Snap a -> SnapletInit b b -> IO () +-- | Initialize and run a Snaplet. This function parses command-line arguments, +-- runs the given Snaplet initializer, and starts an HTTP server running the +-- Snaplet's toplevel 'Handler'. +serveSnaplet :: Config Snap AppConfig + -- ^ The configuration of the server - you can usually pass a + -- default 'Config' via + -- 'Snap.Http.Server.Config.defaultConfig'. + -> SnapletInit b b + -- ^ The snaplet initializer function. + -> IO () serveSnaplet startConfig initializer = do - (msgs, handler, doCleanup) <- runSnaplet initializer + config <- commandLineAppConfig startConfig + serveSnapletNoArgParsing config initializer - config <- commandLineConfig startConfig +------------------------------------------------------------------------------ +-- | Like 'serveSnaplet', but don't try to parse command-line arguments. +serveSnapletNoArgParsing :: Config Snap AppConfig + -- ^ The configuration of the server - you can usually pass a + -- default 'Config' via + -- 'Snap.Http.Server.Config.defaultConfig'. + -> SnapletInit b b + -- ^ The snaplet initializer function. + -> IO () +serveSnapletNoArgParsing config initializer = do + let env = appEnvironment =<< getOther config + (msgs, handler, doCleanup) <- runSnaplet env initializer + (conf, site) <- combineConfig config handler createDirectoryIfMissing False "log" - let serve = simpleHttpServe conf + let serve = httpServe conf - liftIO $ hPutStrLn stderr $ T.unpack msgs + when (loggingEnabled conf) $ liftIO $ hPutStrLn stderr $ T.unpack msgs _ <- try $ serve $ site :: IO (Either SomeException ()) doCleanup + where + loggingEnabled = not . (== Just False) . getVerbose + + +------------------------------------------------------------------------------ +-- | Allows you to get all of your app's config data in the IO monad without +-- the web server infrastructure. +loadAppConfig :: FileName + -- ^ The name of the config file to look for. In snap + -- applications, this is something based on the + -- environment...i.e. @devel.cfg@. + -> FilePath + -- ^ Path to the root directory of your project. + -> IO C.Config +loadAppConfig cfg root = do + tree <- buildL root + let groups = loadAppConfig' cfg "" $ dirTree tree + loadGroups groups + + +------------------------------------------------------------------------------ +-- | Recursive worker for loadAppConfig. +loadAppConfig' :: FileName -> Text -> DirTree a -> [(Text, Worth a)] +loadAppConfig' cfg _prefix d@(Dir _ c) = + (map ((_prefix,) . Required) $ getCfg cfg d) ++ + concatMap (\a -> loadAppConfig' cfg (nextPrefix $ name a) a) snaplets + where + nextPrefix p = T.concat [_prefix, T.pack p, "."] + snapletsDirs = filter isSnapletsDir c + snaplets = concatMap (filter isDir . contents) snapletsDirs +loadAppConfig' _ _ _ = [] + + +isSnapletsDir :: DirTree t -> Bool +isSnapletsDir (Dir "snaplets" _) = True +isSnapletsDir _ = False + + +isDir :: DirTree t -> Bool +isDir (Dir _ _) = True +isDir _ = False + + +isCfg :: FileName -> DirTree t -> Bool +isCfg cfg (File n _) = cfg == n +isCfg _ _ = False + + +getCfg :: FileName -> DirTree b -> [b] +getCfg cfg (Dir _ c) = map file $ filter (isCfg cfg) c +getCfg _ _ = [] + diff --git a/src/Snap/Snaplet/Internal/LensT.hs b/src/Snap/Snaplet/Internal/LensT.hs --- a/src/Snap/Snaplet/Internal/LensT.hs +++ b/src/Snap/Snaplet/Internal/LensT.hs @@ -2,83 +2,114 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Snap.Snaplet.Internal.LensT where -import Control.Applicative -import Control.Category -import Control.Monad.CatchIO -import Control.Monad.Reader -import Control.Monad.State.Class -import Data.Lens.Lazy -import Prelude hiding ((.), id, catch) -import Snap.Core -import Snap.Snaplet.Internal.RST +------------------------------------------------------------------------------ +import Control.Applicative (Alternative (..), + Applicative (..)) +import Control.Category ((.)) +import Control.Lens (ALens', cloneLens, storing, (^#)) +import Control.Monad (MonadPlus (..)) +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.State.Class (MonadState (..)) +import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), + MonadTransControl (..), + defaultLiftBaseWith, + defaultLiftWith, defaultRestoreM, + defaultRestoreT) +import Prelude (Functor (..), Monad (..), const, + ($), ($!)) +import Snap.Core (MonadSnap (..)) +import Snap.Snaplet.Internal.RST (RST (..), runRST, withRST) +------------------------------------------------------------------------------ -newtype LensT b v s m a = LensT (RST (Lens b v) s m a) +newtype LensT b v s m a = LensT (RST (ALens' b v) s m a) deriving ( Monad , MonadTrans , Functor , Applicative , MonadIO , MonadPlus - , MonadCatchIO , Alternative - , MonadReader (Lens b v) - , MonadSnap ) + , MonadReader (ALens' b v)) ------------------------------------------------------------------------------ -instance (Monad m) => MonadState v (LensT b v b m) where +instance Monad m => MonadState v (LensT b v b m) where get = lGet put = lPut +instance MonadBase bs m => MonadBase bs (LensT b v s m) where + liftBase = lift . liftBase + + +instance MonadBaseControl bs m => MonadBaseControl bs (LensT b v s m) where + type StM (LensT b v s m) a = ComposeSt (LensT b v s) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + + +instance MonadTransControl (LensT b v s) where + type StT (LensT b v s) a = StT (RST (ALens' b v) s) a + liftWith = defaultLiftWith LensT (\(LensT rst) -> rst) + restoreT = defaultRestoreT LensT + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} + + +instance MonadSnap m => MonadSnap (LensT b v s m) where + liftSnap m = LensT $ liftSnap m + + ------------------------------------------------------------------------------ -getBase :: (Monad m) => LensT b v s m s +getBase :: Monad m => LensT b v s m s getBase = LensT get {-# INLINE getBase #-} ------------------------------------------------------------------------------ -putBase :: (Monad m) => s -> LensT b v s m () +putBase :: Monad m => s -> LensT b v s m () putBase = LensT . put {-# INLINE putBase #-} ------------------------------------------------------------------------------ -lGet :: (Monad m) => LensT b v b m v +lGet :: Monad m => LensT b v b m v lGet = LensT $ do !l <- ask !b <- get - return $! l ^$ b + return $! b ^# l {-# INLINE lGet #-} ------------------------------------------------------------------------------ -lPut :: (Monad m) => v -> LensT b v b m () +lPut :: Monad m => v -> LensT b v b m () lPut v = LensT $ do !l <- ask !b <- get - put $! (l ^!= v) b + put $! storing l v b {-# INLINE lPut #-} ------------------------------------------------------------------------------ -runLensT :: (Monad m) => - LensT b v s m a - -> Lens b v - -> s - -> m (a, s) -runLensT (LensT m) = runRST m +runLensT :: Monad m => LensT b v s m a -> ALens' b v -> s -> m (a, s) +runLensT (LensT m) l = runRST m l {-# INLINE runLensT #-} ------------------------------------------------------------------------------ -withLensT :: Monad m => - ((Lens b' v') -> (Lens b v)) +withLensT :: Monad m + => (ALens' b' v' -> ALens' b v) -> LensT b v s m a -> LensT b' v' s m a withLensT f (LensT m) = LensT $ withRST f m @@ -87,19 +118,14 @@ ------------------------------------------------------------------------------ withTop :: Monad m - => (Lens b v') + => ALens' b v' -> LensT b v' s m a -> LensT b v s m a -withTop !subLens = withLensT (const subLens) +withTop subLens = withLensT (const subLens) {-# INLINE withTop #-} ------------------------------------------------------------------------------ -with :: Monad m - => (Lens v v') - -> LensT b v' s m a - -> LensT b v s m a -with !subLens = withLensT (subLens .) -{-# INLINE with #-} - +with :: Monad m => ALens' v v' -> LensT b v' s m a -> LensT b v s m a +with subLens = withLensT (\l -> cloneLens l . subLens) diff --git a/src/Snap/Snaplet/Internal/Lensed.hs b/src/Snap/Snaplet/Internal/Lensed.hs --- a/src/Snap/Snaplet/Internal/Lensed.hs +++ b/src/Snap/Snaplet/Internal/Lensed.hs @@ -1,24 +1,36 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Snap.Snaplet.Internal.Lensed where -import Control.Applicative -import Control.Monad -import Control.Monad.Trans -import Data.Lens.Strict -import Control.Monad.CatchIO -import Control.Monad.Reader.Class -import Control.Monad.State.Class -import Control.Monad.State.Strict -import Control.Category -import Prelude hiding (catch, id, (.)) -import Snap.Core +------------------------------------------------------------------------------ +import Control.Applicative (Alternative (..), + Applicative (..), (<$>)) +import Control.Category ((.)) +import Control.Lens (ALens', cloneLens, storing, (^#)) +import Control.Monad (MonadPlus (..), liftM) +import Control.Monad.Base (MonadBase (..)) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.State.Class (MonadState (..)) +import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), + MonadTransControl (..), + defaultLiftBaseWith, + defaultRestoreM) +import Control.Monad.Trans.State (StateT(..)) +import Prelude (Functor (..), Monad (..), ($)) +import Snap.Core (MonadSnap (..)) +------------------------------------------------------------------------------ + ------------------------------------------------------------------------------ newtype Lensed b v m a = Lensed - { unlensed :: Lens b v -> v -> b -> m (a, v, b) } + { unlensed :: ALens' b v -> v -> b -> m (a, v, b) } ------------------------------------------------------------------------------ @@ -36,6 +48,11 @@ ------------------------------------------------------------------------------ +instance Fail.MonadFail m => Fail.MonadFail (Lensed b v m) where + fail s = Lensed $ \_ _ _ -> Fail.fail s + + +------------------------------------------------------------------------------ instance Monad m => Monad (Lensed b v m) where return a = Lensed $ \_ v s -> return (a, v, s) Lensed g >>= k = Lensed $ \l v s -> do @@ -49,20 +66,21 @@ put v' = Lensed $ \_ _ s -> return ((), v', s) ------------------------------------------------------------------------------- -instance Monad m => MonadReader (Lens b v) (Lensed b v m) where - ask = Lensed $ \l v s -> return (l, v, s) - local f g = do - l' <- asks f - withTop l' g +instance Monad m => MonadReader (ALens' b v) (Lensed b v m) where + ask = Lensed $ \l v s -> return (l, v, s) + local = lensedLocal +------------------------------------------------------------------------------ +lensedLocal :: Monad m => (ALens' b v -> ALens' b v') -> Lensed b v' m a -> Lensed b v m a +lensedLocal f g = do + l <- ask + withTop (f l) g ------------------------------------------------------------------------------ instance MonadTrans (Lensed b v) where lift m = Lensed $ \_ v b -> do - res <- m - return (res, v, b) - + res <- m + return (res, v, b) ------------------------------------------------------------------------------ instance MonadIO m => MonadIO (Lensed b v m) where @@ -70,17 +88,6 @@ ------------------------------------------------------------------------------ -instance MonadCatchIO m => MonadCatchIO (Lensed b v m) where - catch (Lensed m) f = Lensed $ \l v b -> m l v b `catch` handler l v b - where - handler l v b e = let (Lensed h) = f e - in h l v b - - block (Lensed m) = Lensed $ \l v b -> block (m l v b) - unblock (Lensed m) = Lensed $ \l v b -> unblock (m l v b) - - ------------------------------------------------------------------------------- instance MonadPlus m => MonadPlus (Lensed b v m) where mzero = lift mzero m `mplus` n = Lensed $ \l v b -> @@ -90,7 +97,7 @@ ------------------------------------------------------------------------------ instance (Monad m, Alternative m) => Alternative (Lensed b v m) where empty = lift empty - (Lensed m) <|> (Lensed n) = Lensed $ \l v b -> m l v b <|> n l v b + Lensed m <|> Lensed n = Lensed $ \l v b -> m l v b <|> n l v b ------------------------------------------------------------------------------ @@ -99,53 +106,77 @@ ------------------------------------------------------------------------------ +instance MonadBase base m => MonadBase base (Lensed b v m) where + liftBase = lift . liftBase + + +------------------------------------------------------------------------------ +instance MonadBaseControl base m => MonadBaseControl base (Lensed b v m) where + type StM (Lensed b v m) a = ComposeSt (Lensed b v) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + + +------------------------------------------------------------------------------ +instance MonadTransControl (Lensed b v) where + type StT (Lensed b v) a = (a, v, b) + liftWith f = Lensed $ \l v b -> do + res <- f $ \(Lensed g) -> g l v b + return (res, v, b) + restoreT k = Lensed $ \_ _ _ -> k + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} + + +------------------------------------------------------------------------------ +globally :: Monad m => StateT b m a -> Lensed b v m a +globally (StateT f) = Lensed $ \l v s -> + liftM (\(a, s') -> (a, s' ^# l, s')) $ f (storing l v s) + + +------------------------------------------------------------------------------ +lensedAsState :: Monad m => Lensed b v m a -> ALens' b v -> StateT b m a +lensedAsState (Lensed f) l = StateT $ \s -> do + (a, v', s') <- f l (s ^# l) s + return (a, storing l v' s') + + +------------------------------------------------------------------------------ getBase :: Monad m => Lensed b v m b getBase = Lensed $ \_ v b -> return (b, v, b) ------------------------------------------------------------------------------ -withTop :: Monad m => Lens b v' -> Lensed b v' m a -> Lensed b v m a +withTop :: Monad m => ALens' b v' -> Lensed b v' m a -> Lensed b v m a withTop l m = globally $ lensedAsState m l ------------------------------------------------------------------------------ -with :: Monad m => Lens v v' -> Lensed b v' m a -> Lensed b v m a +with :: Monad m => ALens' v v' -> Lensed b v' m a -> Lensed b v m a with l g = do - l' <- asks (l .) - withTop l' g + l' <- ask + withTop (cloneLens l' . l) g ------------------------------------------------------------------------------ -embed :: Monad m => Lens v v' -> Lensed v v' m a -> Lensed b v m a +embed :: Monad m => ALens' v v' -> Lensed v v' m a -> Lensed b v m a embed l m = locally $ lensedAsState m l ------------------------------------------------------------------------------ -globally :: Monad m => StateT b m a -> Lensed b v m a -globally (StateT f) = Lensed $ \l v s -> - liftM (\(a, s') -> (a, l ^$ s', s')) $ f (l ^= v $ s) - - ------------------------------------------------------------------------------- locally :: Monad m => StateT v m a -> Lensed b v m a locally (StateT f) = Lensed $ \_ v s -> liftM (\(a, v') -> (a, v', s)) $ f v ------------------------------------------------------------------------------ -lensedAsState :: Monad m => Lensed b v m a -> Lens b v -> StateT b m a -lensedAsState (Lensed f) l = StateT $ \s -> do - (a, v', s') <- f l (l ^$ s) s - return (a, l ^= v' $ s') - - ------------------------------------------------------------------------------- runLensed :: Monad m => Lensed t1 b m t - -> Lens t1 b + -> ALens' t1 b -> t1 -> m (t, t1) runLensed (Lensed f) l s = do - (a, v', s') <- f l (l ^$ s) s - return (a, l ^= v' $ s') - + (a, v', s') <- f l (s ^# l) s + return (a, storing l v' s') diff --git a/src/Snap/Snaplet/Internal/RST.hs b/src/Snap/Snaplet/Internal/RST.hs --- a/src/Snap/Snaplet/Internal/RST.hs +++ b/src/Snap/Snaplet/Internal/RST.hs @@ -1,16 +1,24 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Snap.Snaplet.Internal.RST where -import Control.Applicative -import Control.Category -import Control.Monad.CatchIO -import Control.Monad.Reader -import Control.Monad.State.Class -import Prelude hiding ((.), id, catch) -import Snap.Core +import Control.Applicative (Alternative (..), + Applicative (..)) +import Control.Monad +import Control.Monad.Base (MonadBase (..)) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.State.Class (MonadState (..)) +import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), + MonadTransControl (..), + defaultLiftBaseWith, + defaultRestoreM) +import Snap.Core (MonadSnap (..)) ------------------------------------------------------------------------------ @@ -66,12 +74,6 @@ mapRST f m = RST $ \r s -> f (runRST m r s) -instance (MonadCatchIO m) => MonadCatchIO (RST r s m) where - m `catch` f = RST $ \r s -> runRST m r s - `catch` \e -> runRST (f e) r s - block = mapRST block - unblock = mapRST unblock - instance (MonadSnap m) => MonadSnap (RST r s m) where liftSnap s = lift $ liftSnap s @@ -89,21 +91,45 @@ instance (Monad m) => Monad (RST r s m) where return a = RST $ \_ s -> return (a, s) (>>=) = rwsBind +#if !MIN_VERSION_base(4,13,0) fail msg = RST $ \_ _ -> fail msg +#endif +instance Fail.MonadFail m => Fail.MonadFail (RST r s m) where + fail msg = RST $ \_ _ -> Fail.fail msg instance (MonadPlus m) => MonadPlus (RST r s m) where mzero = RST $ \_ _ -> mzero m `mplus` n = RST $ \r s -> runRST m r s `mplus` runRST n r s +instance (MonadIO m) => MonadIO (RST r s m) where + liftIO = lift . liftIO + + instance MonadTrans (RST r s) where lift m = RST $ \_ s -> do a <- m return $ s `seq` (a, s) -instance (MonadIO m) => MonadIO (RST r s m) where - liftIO = lift . liftIO +instance MonadBase b m => MonadBase b (RST r s m) where + liftBase = lift . liftBase +instance MonadBaseControl b m => MonadBaseControl b (RST r s m) where + type StM (RST r s m) a = ComposeSt (RST r s) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + + +instance MonadTransControl (RST r s) where + type StT (RST r s) a = (a, s) + liftWith f = RST $ \r s -> do + res <- f $ \(RST g) -> g r s + return (res, s) + restoreT k = RST $ \_ _ -> k + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} diff --git a/src/Snap/Snaplet/Internal/Types.hs b/src/Snap/Snaplet/Internal/Types.hs --- a/src/Snap/Snaplet/Internal/Types.hs +++ b/src/Snap/Snaplet/Internal/Types.hs @@ -1,34 +1,52 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +#ifndef MIN_VERSION_comonad +#define MIN_VERSION_comonad(x,y,z) 1 +#endif + module Snap.Snaplet.Internal.Types where -import Prelude hiding ((.), id) -import Control.Applicative -import Control.Category ((.), id) -import Control.Monad.CatchIO hiding (Handler) -import Control.Monad.Reader -import Control.Monad.State.Class -import Control.Monad.Trans.Writer hiding (pass) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Configurator.Types -import Data.IORef -import Data.Monoid -import Data.Lens.Lazy -import Data.Lens.Template -import Data.Text (Text) +------------------------------------------------------------------------------ +import Control.Applicative (Alternative) +import Control.Lens (ALens', makeLenses, set) +import Control.Monad (MonadPlus, liftM) +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.Fail (MonadFail) +import Control.Monad.Reader (MonadIO (..), MonadReader (ask, local)) +import Control.Monad.State.Class (MonadState (get, put), gets) +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Writer (WriterT) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B (dropWhile, intercalate, null, reverse) +import Data.Configurator.Types (Config) +import Data.IORef (IORef) +import Data.Text (Text) +import Snap.Core (MonadSnap, Request (rqClientAddr), Snap, bracketSnap, getRequest, pass, writeText) +import qualified Snap.Snaplet.Internal.Lensed as L (Lensed (..), runLensed, with, withTop) +import qualified Snap.Snaplet.Internal.LensT as LT (LensT, getBase, with, withTop) -import Snap.Core -import qualified Snap.Snaplet.Internal.LensT as LT -import qualified Snap.Snaplet.Internal.Lensed as L +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative) +import Data.Monoid (Monoid (mappend, mempty)) +#endif +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup(..)) +#endif ------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ -- | An opaque data type holding internal snaplet configuration data. It is -- exported publicly because the getOpaqueConfig function in MonadSnaplet -- makes implementing new instances of MonadSnaplet more convenient. @@ -40,16 +58,23 @@ , _scUserConfig :: Config , _scRouteContext :: [ByteString] , _scRoutePattern :: Maybe ByteString - -- ^ Holds the actual route pattern passed to addRoutes for the current - -- handler. Nothing during initialization and before route dispatech. + -- ^ Holds the actual route pattern passed to addRoutes for the + -- current handler. Nothing during initialization and before route + -- dispatech. , _reloader :: IO (Either Text Text) -- might change + -- ^ This is the universal reload action for the top-level site. We + -- can't update this in place to be a reloader for each individual + -- snaplet because individual snaplets can't be reloaded in isolation + -- without losing effects that subsequent hooks may have had. } +makeLenses ''SnapletConfig + ------------------------------------------------------------------------------ -- | Joins a reversed list of directories into a path. buildPath :: [ByteString] -> ByteString -buildPath ps = B.intercalate "/" $ reverse ps +buildPath ps = B.intercalate "/" $ filter (not . B.null) $ reverse ps ------------------------------------------------------------------------------ @@ -68,30 +93,65 @@ -- the snaplet's configuration, the snaplet's root directory on the -- filesystem, the snaplet's root URL, and so on. data Snaplet s = Snaplet - { _snapletConfig :: SnapletConfig - , _snapletValue :: s + { _snapletConfig :: SnapletConfig + , _snapletModifier :: s -> IO () + -- ^ See the _reloader comment for why we have to use this to reload + -- single snaplets in isolation. This action won't actually run the + -- initializer at all. It will only modify the existing state. It is + -- the responsibility of the snaplet author to avoid using this in + -- situations where it will destroy data in its state that was created + -- by subsequent hook actions. + , _snapletValue :: s } - -makeLenses [''SnapletConfig, ''Snaplet] +makeLenses ''Snaplet +--instance Functor Snaplet where +-- fmap f (Snaplet c r a) = Snaplet c r (f a) +-- +--instance Foldable Snaplet where +-- foldMap f (Snaplet _ _ a) = f a +-- +--instance Traversable Snaplet where +-- traverse f (Snaplet c r a) = Snaplet c r <$> f a +-- +--instance Comonad Snaplet where +-- extract (Snaplet _ _ a) = a +-- +-- #if !(MIN_VERSION_comonad(3,0,0)) +-- instance Extend Snaplet where +-- #endif +-- extend f w@(Snaplet c r _) = Snaplet c r (f w) +{- ------------------------------------------------------------------------------ -- | A lens referencing the opaque SnapletConfig data type held inside -- Snaplet. -snapletConfig :: Lens (Snaplet a) SnapletConfig +snapletConfig :: SimpleLens (Snaplet a) SnapletConfig ------------------------------------------------------------------------------ -- | A lens referencing the user-defined state type wrapped by a Snaplet. -snapletValue :: Lens (Snaplet a) a +snapletValue :: SimpleLens (Snaplet a) a +-} +-- NOTE: We cannot use one of the smaller lens packages because none of them +-- include ALens'. We have to use ALens' because we use lenses inside f's... +-- f (Lens a b). That requires ImpredicativeTypes which doesn't work. We +-- also can't inline the type aliases because ALens' uses Pretext which is a +-- newtype and can't be supplied outside lens in a compatible way. + ------------------------------------------------------------------------------ +type SnapletLens s a = ALens' s (Snaplet a) + + +------------------------------------------------------------------------------ -- | Transforms a lens of the type you get from makeLenses to an similar lens -- that is more suitable for internal use. -subSnaplet :: (Lens a (Snaplet b)) -> (Lens (Snaplet a) (Snaplet b)) -subSnaplet = (. snapletValue) +subSnaplet :: SnapletLens a b + -> SnapletLens (Snaplet a) b +subSnaplet l = snapletValue . l ------------------------------------------------------------------------------ @@ -108,21 +168,21 @@ -- think about snaplet lenses using a filesystem path metaphor, the lens -- supplied to this snaplet must be a relative path. In other words, the -- lens's base state must be the same as the current snaplet. - with :: (Lens v (Snaplet v')) - -- ^ A relative lens identifying a snaplet + with :: SnapletLens v v' + -- ^ A relative lens identifying a snaplet -> m b v' a - -- ^ Action from the lense's snaplet + -- ^ Action from the lense's snaplet -> m b v a - with = with' . subSnaplet + with l = with' (subSnaplet l) -- | Like 'with' but doesn't impose the requirement that the action -- being run be a descendant of the current snaplet. Using our filesystem -- metaphor again, the lens for this function must be an absolute -- path--it's base must be the same as the current base. - withTop :: (Lens b (Snaplet v')) - -- ^ An \"absolute\" lens identifying a snaplet + withTop :: SnapletLens b v' + -- ^ An \"absolute\" lens identifying a snaplet -> m b v' a - -- ^ Action from the lense's snaplet + -- ^ Action from the lense's snaplet -> m b v a withTop l = withTop' (subSnaplet l) @@ -133,7 +193,8 @@ -- however the lens returned by 'getLens' will. -- -- @with = with' . subSnaplet@ - with' :: (Lens (Snaplet v) (Snaplet v')) -> m b v' a -> m b v a + with' :: SnapletLens (Snaplet v) v' + -> m b v' a -> m b v a -- Not providing a definition for this function in terms of withTop' -- allows us to avoid extra Monad type class constraints, making the type @@ -141,10 +202,11 @@ -- with' l m = flip withTop m . (l .) =<< getLens -- | The absolute version of 'with'' - withTop' :: (Lens (Snaplet b) (Snaplet v')) -> m b v' a -> m b v a + withTop' :: SnapletLens (Snaplet b) v' + -> m b v' a -> m b v a -- | Gets the lens for the current snaplet. - getLens :: m b v (Lens (Snaplet b) (Snaplet v)) + getLens :: m b v (SnapletLens (Snaplet b) v) -- | Gets the current snaplet's opaque config data type. You'll only use -- this function when writing MonadSnaplet instances. @@ -192,6 +254,18 @@ ------------------------------------------------------------------------------ +-- | Constructs a url relative to the current snaplet. +snapletURL :: (Monad (m b v), MonadSnaplet m) + => ByteString -> m b v ByteString +snapletURL suffix = do + cfg <- getOpaqueConfig + return $ buildPath (cleanSuffix : _scRouteContext cfg) + where + dropSlash = B.dropWhile (=='/') + cleanSuffix = B.reverse $ dropSlash $ B.reverse $ dropSlash suffix + + +------------------------------------------------------------------------------ -- | Snaplet infrastructure is available during runtime request processing -- through the Handler monad. There aren't very many standalone functions to -- read about here, but this is deceptive. The key is in the type class @@ -200,18 +274,39 @@ -- 'MonadSnaplet' instance, which gives you all the functionality described -- above. newtype Handler b v a = - Handler (L.Lensed (Snaplet b) (Snaplet v) Snap a) + Handler { _unHandler :: L.Lensed (Snaplet b) (Snaplet v) Snap a } deriving ( Monad , Functor , Applicative + , MonadFail , MonadIO , MonadPlus - , MonadCatchIO , Alternative , MonadSnap) ------------------------------------------------------------------------------ +instance MonadBase IO (Handler b v) where + liftBase = liftIO + + +------------------------------------------------------------------------------ +newtype StMHandler b v a = StMHandler { + unStMHandler :: StM (L.Lensed (Snaplet b) (Snaplet v) Snap) a + } + + +instance MonadBaseControl IO (Handler b v) where + type StM (Handler b v) a = StMHandler b v a + liftBaseWith f = Handler + $ liftBaseWith + $ \g' -> f + $ \m -> liftM StMHandler + $ g' $ _unHandler m + restoreM = Handler . restoreM . unStMHandler + + +------------------------------------------------------------------------------ -- | Gets the @Snaplet v@ from the current snaplet's state. getSnapletState :: Handler b v (Snaplet v) getSnapletState = Handler get @@ -241,12 +336,27 @@ ------------------------------------------------------------------------------ --- | The MonadState instance gives you access to the current snaplet's state. +-- | Lets you access the current snaplet's state through the 'MonadState' +-- interface. instance MonadState v (Handler b v) where get = getsSnapletState _snapletValue - put v = modifySnapletState (setL snapletValue v) + put v = modifySnapletState (set snapletValue v) +------------------------------------------------------------------------------ +-- | Lets you access the current snaplet's state through the 'MonadReader' +-- interface. +instance MonadReader v (Handler b v) where + ask = getsSnapletState _snapletValue + local f m = do + cur <- ask + put (f cur) + res <- m + put cur + return res + + +------------------------------------------------------------------------------ instance MonadSnaplet Handler where getLens = Handler ask with' !l (Handler !m) = Handler $ L.with l m @@ -255,10 +365,19 @@ ------------------------------------------------------------------------------ +-- | Like 'runBase', but it doesn't require an MVar to be executed. +runPureBase :: Handler b b a -> Snaplet b -> Snap a +runPureBase (Handler m) b = do + (!a, _) <- L.runLensed m id b + return $! a + + +------------------------------------------------------------------------------ -- | Gets the route pattern that matched for the handler. This lets you find -- out exactly which of the strings you used in addRoutes matched. getRoutePattern :: Handler b v (Maybe ByteString) -getRoutePattern = withTop' id $ liftM _scRoutePattern getOpaqueConfig +getRoutePattern = + withTop' id $ liftM _scRoutePattern getOpaqueConfig ------------------------------------------------------------------------------ @@ -267,10 +386,28 @@ -- addRoutes. setRoutePattern :: ByteString -> Handler b v () setRoutePattern p = withTop' id $ - modifySnapletState (setL (scRoutePattern . snapletConfig) (Just p)) + modifySnapletState (set (snapletConfig . scRoutePattern) (Just p)) ------------------------------------------------------------------------------ +-- | Check whether the request comes from localhost. +isLocalhost :: MonadSnap m => m Bool +isLocalhost = do + rip <- liftM rqClientAddr getRequest + return $ elem rip [ "127.0.0.1" + , "localhost" + , "::1" ] + + +------------------------------------------------------------------------------ +-- | Pass if the request is not coming from localhost. +failIfNotLocal :: MonadSnap m => m b -> m b +failIfNotLocal m = do + isLocal <- isLocalhost + if isLocal then m else pass + + +------------------------------------------------------------------------------ -- | Handler that reloads the site. reloadSite :: Handler b v () reloadSite = failIfNotLocal $ do @@ -284,14 +421,6 @@ good msg = do writeText msg writeText $ "Site successfully reloaded.\n" - failIfNotLocal m = do - -- FIXME: this moves to auth once control-panel is done - rip <- liftM rqRemoteAddr getRequest - if not $ elem rip [ "127.0.0.1" - , "localhost" - , "::1" ] - then pass - else m ------------------------------------------------------------------------------ @@ -325,25 +454,43 @@ { _isTopLevel :: Bool , _cleanup :: IORef (IO ()) , _handlers :: [(ByteString, Handler b b ())] - -- ^ Handler routes built up and passed to route. + -- ^ Handler routes built up and passed to route. , _hFilter :: Handler b b () -> Handler b b () - -- ^ Generic filtering of handlers + -- ^ Generic filtering of handlers , _curConfig :: SnapletConfig - -- ^ This snaplet config is the incrementally built config for whatever - -- snaplet is currently being constructed. + -- ^ This snaplet config is the incrementally built config for + -- whatever snaplet is currently being constructed. , _initMessages :: IORef Text + , _environment :: String + , masterReloader :: (Snaplet b -> Snaplet b) -> IO () + -- ^ We can't just hae a simple MVar here because MVars can't be + -- chrooted. } ------------------------------------------------------------------------------ -- | Wrapper around IO actions that modify state elements created during -- initialization. -newtype Hook a = Hook (Snaplet a -> IO (Snaplet a)) +newtype Hook a = Hook (Snaplet a -> IO (Either Text (Snaplet a))) +instance Semigroup (Hook a) where + Hook a <> Hook b = Hook $ \s -> do + ea <- a s + case ea of + Left e -> return $ Left e + Right ares -> do + eb <- b ares + case eb of + Left e -> return $ Left e + Right bres -> return $ Right bres + +------------------------------------------------------------------------------ instance Monoid (Hook a) where - mempty = Hook return - (Hook a) `mappend` (Hook b) = Hook (a >=> b) + mempty = Hook (return . Right) +#if !MIN_VERSION_base(4,11,0) + mappend = (<>) +#endif ------------------------------------------------------------------------------ @@ -356,9 +503,10 @@ a) deriving (Applicative, Functor, Monad, MonadIO) -makeLenses [''InitializerState] +makeLenses ''InitializerState +------------------------------------------------------------------------------ instance MonadSnaplet Initializer where getLens = Initializer ask with' !l (Initializer !m) = Initializer $ LT.with l m @@ -370,14 +518,3 @@ -- | Opaque newtype which gives us compile-time guarantees that the user is -- using makeSnaplet and either nestSnaplet or embedSnaplet correctly. newtype SnapletInit b v = SnapletInit (Initializer b v (Snaplet v)) - - ------------------------------------------------------------------------------- --- | Information needed to reload a site. Instead of having snaplets define --- their own reload actions, we store the original site initializer and use it --- instead. -data ReloadInfo b = ReloadInfo - { riRef :: IORef (Snaplet b) - , riAction :: Initializer b b b - } - diff --git a/src/Snap/Snaplet/Session.hs b/src/Snap/Snaplet/Session.hs --- a/src/Snap/Snaplet/Session.hs +++ b/src/Snap/Snaplet/Session.hs @@ -1,6 +1,5 @@ module Snap.Snaplet.Session - ( SessionManager(..) - , ISessionManager(..) + ( SessionManager , withSession , commitSession , setInSession @@ -11,21 +10,21 @@ , resetSession , touchSession + -- * Utilities Exported For Convenience , module Snap.Snaplet.Session.Common , module Snap.Snaplet.Session.SecureCookie ) where ------------------------------------------------------------------------------ import Control.Monad.State -import Data.Lens.Lazy -import Data.Text (Text) +import Data.Text (Text) import Snap.Core ------------------------------------------------------------------------------ import Snap.Snaplet import Snap.Snaplet.Session.Common import Snap.Snaplet.Session.SecureCookie -import Snap.Snaplet.Session.SessionManager - ( SessionManager(..), ISessionManager(..) ) +import Snap.Snaplet.Session.SessionManager + ( ISessionManager(..), SessionManager(..) ) import qualified Snap.Snaplet.Session.SessionManager as SM ------------------------------------------------------------------------------ @@ -33,7 +32,7 @@ ------------------------------------------------------------------------------ -- | Wrap around a handler, committing any changes in the session at the end -- -withSession :: Lens b (Snaplet SessionManager) +withSession :: SnapletLens b SessionManager -> Handler b v a -> Handler b v a withSession l h = do diff --git a/src/Snap/Snaplet/Session/Backends/CookieSession.hs b/src/Snap/Snaplet/Session/Backends/CookieSession.hs --- a/src/Snap/Snaplet/Session/Backends/CookieSession.hs +++ b/src/Snap/Snaplet/Session/Backends/CookieSession.hs @@ -1,28 +1,34 @@ ------------------------------------------------------------------------------ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.Session.Backends.CookieSession - ( initCookieSessionManager - ) where + ( initCookieSessionManager + ) where ------------------------------------------------------------------------------ -import Control.Applicative import Control.Monad.Reader -import Data.ByteString (ByteString) -import Data.Generics -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM -import Data.Hashable (Hashable) -import Data.Serialize (Serialize) -import qualified Data.Serialize as S -import Data.Text (Text) -import Snap.Core (Snap) +import Data.ByteString (ByteString) +import Data.Typeable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Serialize (Serialize) +import qualified Data.Serialize as S +import Data.Text (Text) +import Data.Text.Encoding +import Snap.Core (Snap) import Web.ClientSession + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif ------------------------------------------------------------------------------ import Snap.Snaplet import Snap.Snaplet.Session +import Snap.Snaplet.Session.SessionManager +------------------------------------------------------------------------------- ------------------------------------------------------------------------------ @@ -43,15 +49,22 @@ ------------------------------------------------------------------------------ instance Serialize CookieSession where - put (CookieSession a b) = S.put (a,b) - get = uncurry CookieSession <$> S.get + put (CookieSession a b) = + S.put (encodeUtf8 a, map encodeTuple $ HM.toList b) + get = + let unpack (a,b) = CookieSession (decodeUtf8 a) + (HM.fromList $ map decodeTuple b) + in unpack <$> S.get -instance (Serialize k, Serialize v, Hashable k, - Eq k) => Serialize (HashMap k v) where - put = S.put . HM.toList - get = HM.fromList <$> S.get +encodeTuple :: (Text, Text) -> (ByteString, ByteString) +encodeTuple (a,b) = (encodeUtf8 a, encodeUtf8 b) + +decodeTuple :: (ByteString, ByteString) -> (Text, Text) +decodeTuple (a,b) = (decodeUtf8 a, decodeUtf8 b) + + ------------------------------------------------------------------------------ mkCookieSession :: RNG -> IO CookieSession mkCookieSession rng = do @@ -69,6 +82,10 @@ -- ^ A long encryption key used for secure cookie transport , cookieName :: ByteString -- ^ Cookie name for the session system + , cookieDomain :: Maybe ByteString + -- ^ Cookie domain for session system. You may want to set it to + -- dot prefixed domain name like ".example.com", so the cookie is + -- available to sub domains. , timeOut :: Maybe Int -- ^ Session cookies will be considered "stale" after this many -- seconds. @@ -79,7 +96,7 @@ ------------------------------------------------------------------------------ loadDefSession :: CookieSessionManager -> IO CookieSessionManager -loadDefSession mgr@(CookieSessionManager ses _ _ _ rng) = +loadDefSession mgr@(CookieSessionManager ses _ _ _ _ rng) = case ses of Nothing -> do ses' <- mkCookieSession rng return $! mgr { session = Just ses' } @@ -100,22 +117,23 @@ initCookieSessionManager :: FilePath -- ^ Path to site-wide encryption key -> ByteString -- ^ Session cookie name + -> Maybe ByteString -- ^ Session cookie domain -> Maybe Int -- ^ Session time-out (replay attack protection) -> SnapletInit b SessionManager -initCookieSessionManager fp cn to = +initCookieSessionManager fp cn dom to = makeSnaplet "CookieSession" "A snaplet providing sessions via HTTP cookies." Nothing $ liftIO $ do key <- getKey fp rng <- liftIO mkRNG - return $! SessionManager $ CookieSessionManager Nothing key cn to rng + return $! SessionManager $ CookieSessionManager Nothing key cn dom to rng ------------------------------------------------------------------------------ instance ISessionManager CookieSessionManager where -------------------------------------------------------------------------- - load mgr@(CookieSessionManager r _ _ _ _) = + load mgr@(CookieSessionManager r _ _ _ _ _) = case r of Just _ -> return mgr Nothing -> do @@ -129,7 +147,7 @@ Right cs -> return $ mgr { session = Just cs } -------------------------------------------------------------------------- - commit mgr@(CookieSessionManager r _ _ _ rng) = do + commit mgr@(CookieSessionManager r _ _ _ _ rng) = do pl <- case r of Just r' -> return . Payload $ S.encode r' Nothing -> liftIO (mkCookieSession rng) >>= @@ -145,25 +163,25 @@ touch = id -------------------------------------------------------------------------- - insert k v mgr@(CookieSessionManager r _ _ _ _) = case r of + insert k v mgr@(CookieSessionManager r _ _ _ _ _) = case r of Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' } Nothing -> mgr -------------------------------------------------------------------------- - lookup k (CookieSessionManager r _ _ _ _) = r >>= HM.lookup k . csSession + lookup k (CookieSessionManager r _ _ _ _ _) = r >>= HM.lookup k . csSession -------------------------------------------------------------------------- - delete k mgr@(CookieSessionManager r _ _ _ _) = case r of + delete k mgr@(CookieSessionManager r _ _ _ _ _) = case r of Just r' -> mgr { session = Just $ modSession (HM.delete k) r' } Nothing -> mgr -------------------------------------------------------------------------- - csrf (CookieSessionManager r _ _ _ _) = case r of + csrf (CookieSessionManager r _ _ _ _ _) = case r of Just r' -> csCSRFToken r' Nothing -> "" -------------------------------------------------------------------------- - toList (CookieSessionManager r _ _ _ _) = case r of + toList (CookieSessionManager r _ _ _ _ _) = case r of Just r' -> HM.toList . csSession $ r' Nothing -> [] @@ -183,5 +201,5 @@ ------------------------------------------------------------------------------ -- | Set the client-side value setPayload :: CookieSessionManager -> Payload -> Snap () -setPayload mgr x = setSecureCookie (cookieName mgr) (siteKey mgr) - (timeOut mgr) x +setPayload mgr x = setSecureCookie (cookieName mgr) (cookieDomain mgr) + (siteKey mgr) (timeOut mgr) x diff --git a/src/Snap/Snaplet/Session/Common.hs b/src/Snap/Snaplet/Session/Common.hs --- a/src/Snap/Snaplet/Session/Common.hs +++ b/src/Snap/Snaplet/Session/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ -- | This module contains functionality common among multiple back-ends. -- @@ -11,11 +12,8 @@ ) where ------------------------------------------------------------------------------ -import Control.Applicative import Control.Concurrent import Control.Monad -import Data.Serialize -import qualified Data.Serialize as S import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.Text.Encoding as T @@ -23,7 +21,11 @@ import Numeric import System.Random.MWC +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + ------------------------------------------------------------------------------ -- | High speed, mutable random number generator state newtype RNG = RNG (MVar GenIO) @@ -57,10 +59,3 @@ -- | Generate a randomized CSRF token mkCSRFToken :: RNG -> IO Text mkCSRFToken rng = T.decodeUtf8 <$> randomToken 40 rng - - ------------------------------------------------------------------------------- -instance Serialize Text where - put = S.put . T.encodeUtf8 - get = T.decodeUtf8 <$> S.get - diff --git a/src/Snap/Snaplet/Session/SecureCookie.hs b/src/Snap/Snaplet/Session/SecureCookie.hs --- a/src/Snap/Snaplet/Session/SecureCookie.hs +++ b/src/Snap/Snaplet/Session/SecureCookie.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ -- | This is a support module meant to back all session back-end @@ -12,26 +13,30 @@ -- cookie. This will limit intercept-and-replay attacks by disallowing -- cookies older than the timeout threshold. -module Snap.Snaplet.Session.SecureCookie where - ------------------------------------------------------------------------------- -import Control.Applicative -import Control.Monad -import Control.Monad.Trans -import Data.ByteString (ByteString) -import Data.Time -import Data.Time.Clock.POSIX -import Data.Serialize -import Snap.Core -import Web.ClientSession - +module Snap.Snaplet.Session.SecureCookie + ( SecureCookie + , getSecureCookie + , setSecureCookie + , expireSecureCookie + -- ** Helper functions + , encodeSecureCookie + , decodeSecureCookie + , checkTimeout + ) where ------------------------------------------------------------------------------ --- | Serialize UTCTime -instance Serialize UTCTime where - put t = put (round (utcTimeToPOSIXSeconds t) :: Integer) - get = posixSecondsToUTCTime . fromInteger <$> get +import Control.Monad +import Control.Monad.Trans +import Data.ByteString (ByteString) +import Data.Serialize +import Data.Time +import Data.Time.Clock.POSIX +import Snap.Core +import Web.ClientSession +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif ------------------------------------------------------------------------------ -- | Arbitrary payload with timestamp. @@ -39,7 +44,7 @@ ------------------------------------------------------------------------------ --- Get the payload back +-- | Get the cookie payload. getSecureCookie :: (MonadSnap m, Serialize t) => ByteString -- ^ Cookie name -> Key -- ^ Encryption key @@ -49,9 +54,8 @@ rqCookie <- getCookie name rspCookie <- getResponseCookie name <$> getResponse let ck = rspCookie `mplus` rqCookie - let val = fmap cookieValue ck >>= decrypt key >>= return . decode - let val' = val >>= either (const Nothing) Just - case val' of + let val = fmap cookieValue ck >>= decodeSecureCookie key + case val of Nothing -> return Nothing Just (ts, t) -> do to <- checkTimeout timeout ts @@ -61,19 +65,55 @@ ------------------------------------------------------------------------------ --- | Inject the payload +-- | Decode secure cookie payload wih key. +decodeSecureCookie :: Serialize a + => Key -- ^ Encryption key + -> ByteString -- ^ Encrypted payload + -> Maybe (SecureCookie a) +decodeSecureCookie key value = do + cv <- decrypt key value + (i, val) <- either (const Nothing) Just $ decode cv + return $ (posixSecondsToUTCTime (fromInteger i), val) + + +------------------------------------------------------------------------------ +-- | Inject the payload. setSecureCookie :: (MonadSnap m, Serialize t) => ByteString -- ^ Cookie name + -> Maybe ByteString -- ^ Cookie domain -> Key -- ^ Encryption key -> Maybe Int -- ^ Max age in seconds -> t -- ^ Serializable payload -> m () -setSecureCookie name key to val = do +setSecureCookie name domain key to val = do t <- liftIO getCurrentTime + val' <- encodeSecureCookie key (t, val) let expire = to >>= Just . flip addUTCTime t . fromIntegral - val' <- liftIO . encryptIO key . encode $ (t, val) - let nc = Cookie name val' expire Nothing (Just "/") False True + let nc = Cookie name val' expire domain (Just "/") False True modifyResponse $ addResponseCookie nc + + +------------------------------------------------------------------------------ +-- | Encode SecureCookie with key into injectable payload +encodeSecureCookie :: (MonadIO m, Serialize t) + => Key -- ^ Encryption key + -> SecureCookie t -- ^ Payload + -> m ByteString +encodeSecureCookie key (t, val) = + liftIO $ encryptIO key . encode $ (seconds, val) + where + seconds = round (utcTimeToPOSIXSeconds t) :: Integer + + +------------------------------------------------------------------------------ +-- | Expire secure cookie +expireSecureCookie :: MonadSnap m + => ByteString -- ^ Cookie name + -> Maybe ByteString -- ^ Cookie domain + -> m () +expireSecureCookie name domain = expireCookie cookie + where + cookie = Cookie name "" Nothing domain (Just "/") False False ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Session/SessionManager.hs b/src/Snap/Snaplet/Session/SessionManager.hs --- a/src/Snap/Snaplet/Session/SessionManager.hs +++ b/src/Snap/Snaplet/Session/SessionManager.hs @@ -1,16 +1,30 @@ {-# LANGUAGE ExistentialQuantification #-} +{-| This module is meant to be used mainly by Session backend +developers, who would naturally need access to ISessionManager class +internals. You can also use it if you need low-level access to the +backend functionality.-} + module Snap.Snaplet.Session.SessionManager where +------------------------------------------------------------------------------- import Data.Text (Text) -import Prelude hiding (lookup) - +import Prelude hiding (lookup) +------------------------------------------------------------------------------- import Snap.Core (Snap) +------------------------------------------------------------------------------- --- | Any Haskell record that is a member of the 'ISessionManager' typeclass --- can be stuffed inside a 'SessionManager' to enable all session-related --- functionality. + +-- | Any Haskell record that is a member of the 'ISessionManager' +-- typeclass can be stuffed inside a 'SessionManager' to enable all +-- session-related functionality. +-- +-- To use sessions in your application, just find a Backend that would +-- produce one for you inside of your 'Initializer'. See +-- 'initCookieSessionManager' in +-- 'Snap.Snaplet.Session.Backends.CookieSession' for a built-in option +-- that would get you started. data SessionManager = forall a. ISessionManager a => SessionManager a 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,142 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - ------------------------------------------------------------------------------- -import Data.Char -import Data.List -import qualified Data.ByteString.Char8 as S -import qualified Data.Text as T -import Snap.Http.Server (snapServerVersion) -import System.Directory -import System.Environment -import System.Exit -import System.Console.GetOpt -import System.FilePath ------------------------------------------------------------------------------- -import Snap.StarterTH - - ------------------------------------------------------------------------------- --- Creates a value tDir :: ([String], [(String, String)]) -buildData "tDirBareBones" "barebones" -buildData "tDirDefault" "default" -buildData "tDirTutorial" "tutorial" - - ------------------------------------------------------------------------------- -usage :: String -usage = unlines - [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter" - , "" - , "Usage:" - , "" - , " snap " - , "" - , " can be one of:" - , " init - create a new project directory structure in the " ++ - "current directory" - , "" - , " Note: you can use --help after any of the above actions to get help " - , " on that action" - ] - - ------------------------------------------------------------------------------- -initUsage :: String -initUsage = unlines - [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter" - , "" - , "Usage:" - , "" - , " snap init [type]" - , "" - , " [type] can be one of:" - , " default - A default project using snaplets and heist" - , " barebones - A barebones project with minimal dependencies" - , " tutorial - The literate Haskell tutorial project" - , "" - , " If [type] is omitted, the default project is generated." - ] - - ------------------------------------------------------------------------------- -printUsage :: [String] -> IO () -printUsage ("init":_) = putStrLn initUsage -printUsage _ = putStrLn usage - - ------------------------------------------------------------------------------- --- Only one option for now -data Option = Help - deriving (Show, Eq) - - ------------------------------------------------------------------------------- -setup :: String -> ([FilePath], [(String, String)]) -> IO () -setup projName tDir = do - mapM createDirectory (fst tDir) - mapM_ write (snd tDir) - where - -------------------------------------------------------------------------- - write (f,c) = - if isSuffixOf "foo.cabal" f - then writeFile (projName ++ ".cabal") (insertProjName $ T.pack c) - else writeFile f c - - -------------------------------------------------------------------------- - isNameChar c = isAlphaNum c || c == '-' - - -------------------------------------------------------------------------- - insertProjName c = T.unpack $ T.replace - (T.pack "projname") - (T.pack $ filter isNameChar projName) c - - ------------------------------------------------------------------------------- -initProject :: [String] -> IO () -initProject args = do - case getOpt Permute options args of - (flags, other, []) - | Help `elem` flags -> printUsage other >> exitFailure - | otherwise -> go other - - (_, other, errs) -> do putStrLn $ concat errs - printUsage other - exitFailure - - where - -------------------------------------------------------------------------- - options = - [ Option ['h'] ["help"] (NoArg Help) - "Print this message" - ] - - -------------------------------------------------------------------------- - go ("init":rest) = init' rest - go _ = do - putStrLn "Error: Invalid action!" - putStrLn usage - exitFailure - - -------------------------------------------------------------------------- - init' args' = do - cur <- getCurrentDirectory - let dirs = splitDirectories cur - projName = last dirs - setup' = setup projName - - case args' of - [] -> setup' tDirDefault - ["barebones"] -> setup' tDirBareBones - ["default"] -> setup' tDirDefault - ["tutorial"] -> setup' tDirTutorial - _ -> do - putStrLn initUsage - exitFailure - - ------------------------------------------------------------------------------- -main :: IO () -main = do - args <- getArgs - initProject args diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs deleted file mode 100644 --- a/src/Snap/StarterTH.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Snap.StarterTH where - ------------------------------------------------------------------------------- -import qualified Data.Foldable as F -import Data.List -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import System.Directory.Tree -import System.FilePath ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- Convenience types -type FileData = (String, String) -type DirData = FilePath - - ------------------------------------------------------------------------------- --- Gets all the directories in a DirTree --- -getDirs :: [FilePath] -> DirTree a -> [FilePath] -getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) : - concatMap (getDirs (n:prefix)) c -getDirs _ (File _ _) = [] -getDirs _ (Failed _ _) = [] - - ------------------------------------------------------------------------------- --- Reads a directory and returns a tuple of the list of all directories --- encountered and a list of filenames and content strings. --- -readTree :: FilePath -> IO ([DirData], [FileData]) -readTree dir = do - d <- readDirectory $ dir "." - let ps = zipPaths $ "" :/ (free d) - fd = F.foldr (:) [] ps - dirs = getDirs [] $ free d - return (drop 1 dirs, fd) - - ------------------------------------------------------------------------------- --- Calls readTree and returns its value in a quasiquote. --- -dirQ :: FilePath -> Q Exp -dirQ tplDir = do - d <- runIO . readTree $ "project_template" tplDir - lift d - - ------------------------------------------------------------------------------- --- Creates a declaration assigning the specified name the value returned by --- dirQ. --- -buildData :: String -> FilePath -> Q [Dec] -buildData dirName tplDir = do - let dir = mkName dirName - typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |] - v <- valD (varP dir) (normalB $ dirQ tplDir) [] - - return [typeSig, v] diff --git a/test/bad.tpl b/test/bad.tpl new file mode 100644 --- /dev/null +++ b/test/bad.tpl @@ -0,0 +1,1 @@ + diff --git a/test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl b/test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl +++ /dev/null @@ -1,1 +0,0 @@ -baz template page diff --git a/test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl b/test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl +++ /dev/null @@ -1,1 +0,0 @@ -This is an extra template diff --git a/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl b/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl +++ /dev/null @@ -1,1 +0,0 @@ -embedded snaplet page diff --git a/test/non-cabal-appdir/snaplets/heist/templates/index.tpl b/test/non-cabal-appdir/snaplets/heist/templates/index.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/heist/templates/index.tpl +++ /dev/null @@ -1,1 +0,0 @@ -index page diff --git a/test/non-cabal-appdir/snaplets/heist/templates/page.tpl b/test/non-cabal-appdir/snaplets/heist/templates/page.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/heist/templates/page.tpl +++ /dev/null @@ -1,8 +0,0 @@ - - -Example App - - - - - diff --git a/test/non-cabal-appdir/snaplets/heist/templates/session.tpl b/test/non-cabal-appdir/snaplets/heist/templates/session.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/heist/templates/session.tpl +++ /dev/null @@ -1,1 +0,0 @@ - diff --git a/test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl b/test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl +++ /dev/null @@ -1,1 +0,0 @@ -splice page diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh deleted file mode 100644 --- a/test/runTestsAndCoverage.sh +++ /dev/null @@ -1,60 +0,0 @@ -#!/bin/sh - -set -e - -if [ -z "$DEBUG" ]; then - export DEBUG=snap-testsuite -fi - -SUITE=./dist/build/snap-testsuite/snap-testsuite - -rm -f snap-testsuite.tix - -if [ ! -f $SUITE ]; then - cat </dev/null 2>&1 - -cat <= 1.6 - -Executable snap-testsuite - hs-source-dirs: ../src suite - main-is: TestSuite.hs - - build-depends: - Glob >= 0.5 && < 0.8, - HUnit >= 1.2 && < 2, - MonadCatchIO-transformers >= 0.2 && < 0.4, - QuickCheck >= 2.3.0.2, - attoparsec >= 0.10 && <0.11, - base >= 4 && < 5, - bytestring >= 0.9 && < 0.10, - containers >= 0.3, - data-lens >= 2.0.1 && < 2.11, - data-lens-template >= 2.1.1 && < 2.2, - directory, - directory-tree >= 0.10 && < 0.11, - filepath, - heist >= 0.7 && < 0.9, - http-enumerator >= 0.7.1.7 && < 0.8, - mtl >= 2, - process == 1.*, - snap-core >= 0.8.1 && < 0.9, - snap-server >= 0.8.1 && < 0.9, - test-framework >= 0.6 && <0.7, - test-framework-hunit >= 0.2.7 && <0.3, - test-framework-quickcheck2 >= 0.2.12.1 && <0.3, - text >= 0.11 && < 0.12, - transformers >= 0.2, - unix >= 2.2.0.0 && < 2.6, - utf8-string >= 0.3 && < 0.4, - template-haskell - - extensions: - BangPatterns, - CPP, - DeriveDataTypeable, - ExistentialQuantification, - FlexibleContexts, - FlexibleInstances, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses, - NoMonomorphismRestriction, - OverloadedStrings, - PackageImports, - Rank2Types, - ScopedTypeVariables, - TemplateHaskell, - TypeFamilies, - TypeOperators, - TypeSynonymInstances - - ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded - -fno-warn-unused-do-bind - - -Executable app - hs-source-dirs: ../src suite - main-is: AppMain.hs - - build-depends: - MonadCatchIO-transformers >= 0.2 && < 0.4, - attoparsec >= 0.10 && < 0.11, - base >= 4 && < 5, - bytestring >= 0.9 && < 0.10, - cereal >= 0.3, - clientsession >= 0.7.3.6 && < 0.8, - configurator >= 0.1 && < 0.3, - containers >= 0.3, - data-lens >= 2.0.1 && < 2.11, - data-lens-template >= 2.1.1 && < 2.2, - directory, - directory-tree >= 0.10 && < 0.11, - filepath, - hashable >= 1.1, - heist >= 0.7 && < 0.9, - mtl >= 2, - mwc-random >= 0.8, - process == 1.*, - snap-core >= 0.8.1 && < 0.9, - snap-server >= 0.8.1 && < 0.9, - syb >= 0.1, - time >= 1.1, - text >= 0.11 && < 0.12, - transformers >= 0.2, - unordered-containers >= 0.1.4, - utf8-string >= 0.3 && < 0.4, - template-haskell - --FIXME - - extensions: - BangPatterns, - CPP, - DeriveDataTypeable, - ExistentialQuantification, - FlexibleContexts, - FlexibleInstances, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses, - NoMonomorphismRestriction, - OverloadedStrings, - PackageImports, - Rank2Types, - ScopedTypeVariables, - TemplateHaskell, - TypeFamilies, - TypeOperators, - TypeSynonymInstances - - ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded - -fno-warn-unused-do-bind - -Executable nesttest - hs-source-dirs: ../src suite - main-is: NestTest.hs - - build-depends: - MonadCatchIO-transformers >= 0.2 && < 0.4, - attoparsec >= 0.10 && < 0.11, - base >= 4 && < 5, - bytestring >= 0.9 && < 0.10, - containers >= 0.3, - data-lens >= 2.0.1 && < 2.11, - data-lens-template >= 2.1 && < 2.2, - directory, - directory-tree >= 0.10 && < 0.11, - filepath, - heist >= 0.7 && < 0.9, - mtl >= 2, - process == 1.*, - snap-core >= 0.8.1 && < 0.9, - snap-server >= 0.8.1 && < 0.9, - text >= 0.11 && < 0.12, - transformers >= 0.2, - utf8-string >= 0.3 && < 0.4, - template-haskell - - extensions: - BangPatterns, - CPP, - DeriveDataTypeable, - ExistentialQuantification, - FlexibleContexts, - FlexibleInstances, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses, - NoMonomorphismRestriction, - OverloadedStrings, - PackageImports, - Rank2Types, - ScopedTypeVariables, - TemplateHaskell, - TypeFamilies, - TypeOperators, - TypeSynonymInstances - - ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded - -fno-warn-unused-do-bind - diff --git a/test/snaplets/baz/devel.cfg b/test/snaplets/baz/devel.cfg new file mode 100644 --- /dev/null +++ b/test/snaplets/baz/devel.cfg @@ -0,0 +1,2 @@ +barSnapletField = "barValue" + diff --git a/test/snaplets/baz/templates/bazconfig.tpl b/test/snaplets/baz/templates/bazconfig.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/baz/templates/bazconfig.tpl @@ -0,0 +1,1 @@ +baz config page diff --git a/test/snaplets/baz/templates/bazpage.tpl b/test/snaplets/baz/templates/bazpage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/baz/templates/bazpage.tpl @@ -0,0 +1,1 @@ +baz template page diff --git a/test/snaplets/embedded/extra-templates/extra.tpl b/test/snaplets/embedded/extra-templates/extra.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/embedded/extra-templates/extra.tpl @@ -0,0 +1,1 @@ +This is an extra template diff --git a/test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl b/test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl @@ -0,0 +1,1 @@ +embedded snaplet page diff --git a/test/snaplets/foosnaplet/devel.cfg b/test/snaplets/foosnaplet/devel.cfg new file mode 100644 --- /dev/null +++ b/test/snaplets/foosnaplet/devel.cfg @@ -0,0 +1,2 @@ +fooSnapletField = "fooValue" + diff --git a/test/snaplets/foosnaplet/templates/foopage.tpl b/test/snaplets/foosnaplet/templates/foopage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/foosnaplet/templates/foopage.tpl @@ -0,0 +1,1 @@ +foo template page diff --git a/test/snaplets/heist/templates/_foopage.tpl b/test/snaplets/heist/templates/_foopage.tpl new file mode 100644 --- /dev/null +++ b/test/snaplets/heist/templates/_foopage.tpl @@ -0,0 +1,7 @@ + + + +

An underscore template.

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

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

+ +

loggedInUser:

+ +

UserID

+ +

UserLogin

+ +

UserEmail

+ +

UserActive

+ +

UserLoginCount

+ +

UserFailedCount

+ +

UserLoginAt

+ +

UserLastLoginAt

+ +

UserSuspendedAt

+ +

UserLoginIP

+ +

UserLastLoginIP

+ +

UserIfActive

+ +

userIfSuspended

+ + + + + + diff --git a/test/suite/AppMain.hs b/test/suite/AppMain.hs deleted file mode 100644 --- a/test/suite/AppMain.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import Snap.Http.Server.Config -import Snap.Snaplet - -import Blackbox.App - -main :: IO () -main = serveSnaplet defaultConfig app diff --git a/test/suite/Blackbox/App.hs b/test/suite/Blackbox/App.hs deleted file mode 100644 --- a/test/suite/Blackbox/App.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Blackbox.App where - -import Prelude hiding (lookup) - -import Control.Applicative -import Control.Monad.Trans -import Data.Lens.Lazy -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Configurator -import Snap.Core -import Snap.Util.FileServe - -import Snap.Snaplet -import Snap.Snaplet.Heist -import qualified Snap.Snaplet.HeistNoClass as HNC -import Text.Templating.Heist - -import Blackbox.Common -import Blackbox.BarSnaplet -import Blackbox.FooSnaplet -import Blackbox.EmbeddedSnaplet -import Blackbox.Types -import Snap.Snaplet.Session hiding (lookup) -import Snap.Snaplet.Session.Backends.CookieSession - - -routeWithSplice :: Handler App App () -routeWithSplice = do - str <- with foo getFooField - writeText $ T.pack $ "routeWithSplice: "++str - -routeWithConfig :: Handler App App () -routeWithConfig = do - cfg <- getSnapletUserConfig - val <- liftIO $ lookup cfg "topConfigField" - writeText $ "routeWithConfig: " `T.append` fromJust val - - -sessionDemo :: Handler App App () -sessionDemo = withSession session $ do - with session $ do - curVal <- getFromSession "foo" - case curVal of - Nothing -> do - setInSession "foo" "bar" - Just _ -> return () - list <- with session $ (T.pack . show) `fmap` sessionToList - csrf <- with session $ (T.pack . show) `fmap` csrfToken - HNC.renderWithSplices heist "session" - [ ("session", liftHeist $ textSplice list) - , ("csrf", liftHeist $ textSplice csrf) ] - -sessionTest :: Handler App App () -sessionTest = withSession session $ do - q <- getParam "q" - val <- case q of - Just x -> do - let x' = T.decodeUtf8 x - with session $ setInSession "test" x' - return x' - Nothing -> maybe "" id `fmap` with session (getFromSession "test") - writeText val - -fooMod :: FooSnaplet -> FooSnaplet -fooMod f = f { fooField = fooField f ++ "z" } - -app :: SnapletInit App App -app = makeSnaplet "app" "Test application" Nothing $ do - hs <- nestSnaplet "heist" heist $ heistInit "templates" - fs <- nestSnaplet "foo" foo fooInit - bs <- nestSnaplet "" bar $ nameSnaplet "baz" $ barInit foo - sm <- nestSnaplet "session" session $ - initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60)) - ns <- embedSnaplet "embed" embedded embeddedInit - addSplices - [("appsplice", liftHeist $ textSplice "contents of the app splice")] - HNC.addSplices heist - [("appconfig", shConfigSplice)] - addRoutes [ ("/hello", writeText "hello world") - , ("/routeWithSplice", routeWithSplice) - , ("/routeWithConfig", routeWithConfig) - , ("/public", serveDirectory "public") - , ("/sessionDemo", sessionDemo) - , ("/sessionTest", sessionTest) - ] - wrapHandlers (<|> heistServe) - return $ App hs (modL snapletValue fooMod fs) bs sm ns - - - diff --git a/test/suite/Blackbox/BarSnaplet.hs b/test/suite/Blackbox/BarSnaplet.hs deleted file mode 100644 --- a/test/suite/Blackbox/BarSnaplet.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ExistentialQuantification #-} -module Blackbox.BarSnaplet where - -import Prelude hiding (lookup) - -import Control.Monad.State -import qualified Data.ByteString as B -import Data.Configurator -import Data.Lens.Lazy -import Data.Lens.Template -import Data.Maybe -import Data.Text (Text) -import Snap.Snaplet -import Snap.Snaplet.Heist -import Snap.Core -import Text.Templating.Heist - -import Blackbox.Common -import Blackbox.FooSnaplet - -data BarSnaplet b = BarSnaplet - { _barField :: String - , fooLens :: Lens b (Snaplet FooSnaplet) - } - -makeLens ''BarSnaplet - -barsplice :: [(Text, SnapletHeist b v Template)] -barsplice = [("barsplice", liftHeist $ textSplice "contents of the bar splice")] - -barInit :: HasHeist b - => Lens b (Snaplet FooSnaplet) - -> SnapletInit b (BarSnaplet b) -barInit l = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do - config <- getSnapletUserConfig - addTemplates "" - rootUrl <- getSnapletRootURL - addRoutes [("barconfig", liftIO (lookup config "barSnapletField") >>= writeLBS . fromJust) - ,("barrooturl", writeBS $ "url" `B.append` rootUrl) - ,("bazpage2", renderWithSplices "bazpage" barsplice) - ,("bazpage3", heistServeSingle "bazpage") - ,("bazpage4", renderAs "text/html" "bazpage") - ,("bazpage5", renderWithSplices "bazpage" - [("barsplice", shConfigSplice)]) - ,("bazbadpage", heistServeSingle "cpyga") - ,("bar/handlerConfig", handlerConfig) - ] - return $ BarSnaplet "bar snaplet data string" l - diff --git a/test/suite/Blackbox/Common.hs b/test/suite/Blackbox/Common.hs deleted file mode 100644 --- a/test/suite/Blackbox/Common.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Blackbox.Common where - -import qualified Data.Text as T -import Snap.Core -import Snap.Snaplet -import Snap.Snaplet.Heist -import Text.Templating.Heist - -genericConfigString :: (MonadSnaplet m, Monad (m b v)) => m b v T.Text -genericConfigString = do - a <- getSnapletAncestry - b <- getSnapletFilePath - c <- getSnapletName - d <- getSnapletDescription - e <- getSnapletRootURL - return $ T.pack $ show (a,b,c,d,e) - -handlerConfig :: Handler b v () -handlerConfig = writeText =<< genericConfigString - -shConfigSplice :: SnapletSplice b v -shConfigSplice = liftHeist . textSplice =<< genericConfigString - diff --git a/test/suite/Blackbox/EmbeddedSnaplet.hs b/test/suite/Blackbox/EmbeddedSnaplet.hs deleted file mode 100644 --- a/test/suite/Blackbox/EmbeddedSnaplet.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Blackbox.EmbeddedSnaplet where - -import Prelude hiding ((.)) -import Control.Monad.State -import Data.Lens.Lazy -import Data.Lens.Template -import qualified Data.Text as T -import System.FilePath.Posix - -import Snap.Snaplet -import Snap.Snaplet.Heist -import Text.Templating.Heist - --- If we universally quantify EmbeddedSnaplet to get rid of the type parameter --- mkLabels throws an error "Can't reify a GADT data constructor" -data EmbeddedSnaplet = EmbeddedSnaplet - { _embeddedHeist :: Snaplet (Heist EmbeddedSnaplet) - , _embeddedVal :: Int - } - -makeLenses [''EmbeddedSnaplet] - -instance HasHeist EmbeddedSnaplet where - heistLens = subSnaplet embeddedHeist - -embeddedInit :: SnapletInit EmbeddedSnaplet EmbeddedSnaplet -embeddedInit = makeSnaplet "embedded" "embedded snaplet" Nothing $ do - hs <- nestSnaplet "heist" embeddedHeist $ heistInit "templates" - - -- This is the implementation of addTemplates, but we do it here manually - -- to test coverage for addTemplatesAt. - snapletPath <- getSnapletFilePath - addTemplatesAt "onemoredir" (snapletPath "extra-templates") - - embeddedLens <- getLens - addRoutes [("aoeuhtns", withSplices - [("asplice", embeddedSplice embeddedLens)] - (render "embeddedpage")) - ] - return $ EmbeddedSnaplet hs 42 - - -embeddedSplice :: (Lens (Snaplet b) (Snaplet EmbeddedSnaplet)) - -> SnapletHeist b v Template -embeddedSplice embeddedLens = do - val <- liftWith embeddedLens $ gets _embeddedVal - liftHeist $ textSplice $ T.pack $ "splice value" ++ (show val) - diff --git a/test/suite/Blackbox/FooSnaplet.hs b/test/suite/Blackbox/FooSnaplet.hs deleted file mode 100644 --- a/test/suite/Blackbox/FooSnaplet.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -module Blackbox.FooSnaplet where - -import Prelude hiding (lookup) -import Control.Monad.State -import Data.Configurator -import Data.Maybe -import qualified Data.Text as T -import Snap.Snaplet -import Snap.Snaplet.Heist -import Snap.Core -import Text.Templating.Heist - -import Blackbox.Common - -data FooSnaplet = FooSnaplet { fooField :: String } - -fooInit :: HasHeist b => SnapletInit b FooSnaplet -fooInit = makeSnaplet "foosnaplet" "A demonstration snaplet called foo." - (Just $ return "../foosnaplet") $ do - config <- getSnapletUserConfig - addTemplates "" - addSplices - [("foosplice", liftHeist $ textSplice "contents of the foo splice")] - rootUrl <- getSnapletRootURL - fp <- getSnapletFilePath - name <- getSnapletName - addSplices [("fooconfig", shConfigSplice)] - addRoutes [("fooConfig", liftIO (lookup config "fooSnapletField") >>= writeLBS . fromJust) - ,("fooRootUrl", writeBS rootUrl) - ,("fooSnapletName", writeText $ fromMaybe "empty snaplet name" name) - ,("fooFilePath", writeText $ T.pack fp) - ,("handlerConfig", handlerConfig) - ] - return $ FooSnaplet "foo snaplet data string" - -getFooField :: Handler b FooSnaplet String -getFooField = gets fooField - diff --git a/test/suite/Blackbox/Tests.hs b/test/suite/Blackbox/Tests.hs --- a/test/suite/Blackbox/Tests.hs +++ b/test/suite/Blackbox/Tests.hs @@ -8,30 +8,94 @@ ) where ------------------------------------------------------------------------------ -import Control.Exception (catch, throwIO) +import Control.Exception (catch, finally, throwIO) import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L +import Data.Monoid import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as T -import qualified Network.HTTP.Enumerator as HTTP +import Network.Http.Client import Prelude hiding (catch) import System.Directory import System.FilePath import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) +------------------------------------------------------------------------------ + ------------------------------------------------------------------------------ --- TODO: fix all the hardcoded ports and strings in here, order the functions --- non-randomly +testServer :: String +testServer = "http://127.0.0.1" + + ------------------------------------------------------------------------------ +testPort :: String +testPort = "9753" ------------------------------------------------------------------------------ +-- | The server uri, without the leading slash. +testServerUri :: String +testServerUri = testServer ++ ":" ++ testPort + + +------------------------------------------------------------------------------ +-- | The server url, with the leading slash. +testServerUrl :: String +testServerUrl = testServerUri ++ "/" + + + -------------------- + -- TEST LOADER -- + -------------------- + +------------------------------------------------------------------------------ +tests :: Test +tests = testGroup "non-cabal-tests" + [ requestTest "hello" "hello world" + , requestTest "index" "index page\n" + , requestTest "" "index page\n" + , requestTest "splicepage" "splice page contents of the app splice\n" + , requestTest "routeWithSplice" "routeWithSplice: foo snaplet data stringz" + , requestTest "routeWithConfig" "routeWithConfig: topConfigValue" + , requestTest "foo/foopage" "foo template page\n" + , requestTest "foo/fooConfig" "fooValue" + , requestTest "foo/fooRootUrl" "foo" + , requestTest "barconfig" "barValue" + , requestTest "bazpage" "baz template page \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 @@ -39,30 +103,50 @@ ------------------------------------------------------------------------------ -assertRelativelyTheSame :: FilePath -> FilePath -> IO () -assertRelativelyTheSame p expected = do - b <- makeRelativeToCurrentDirectory p - assertEqual ("expected " ++ expected) expected b +requestTest' :: String -> Text -> IO () +requestTest' url desired = do + actual <- get (S.pack $ testServerUrl ++ url) concatHandler + assertEqual url desired (T.decodeUtf8 $ L.fromChunks [actual]) ------------------------------------------------------------------------------ -testServerUri :: String -testServerUri = "http://127.0.0.1:9753" +requestExpectingErrorPrefix :: String -> Int -> Text -> Test +requestExpectingErrorPrefix url status desired = + testCase (testName url) $ requestExpectingErrorPrefix' url status desired ------------------------------------------------------------------------------ -grab :: MonadIO m => String -> m L.ByteString -grab path = liftIO $ HTTP.simpleHttp $ testServerUri ++ path +requestExpectingErrorPrefix' :: String -> Int -> Text -> IO () +requestExpectingErrorPrefix' url status desired = do + let fullUrl = testServerUrl ++ url + get (S.pack fullUrl) $ \resp is -> do + assertEqual ("Status code: "++fullUrl) status + (getStatusCode resp) + res <- concatHandler resp is + assertBool fullUrl $ desired `T.isPrefixOf` (T.decodeUtf8 $ L.fromChunks [res]) ------------------------------------------------------------------------------ fooConfigPathTest :: Test fooConfigPathTest = testCase (testName "foo/fooFilePath") $ do b <- liftM L.unpack $ grab "/foo/fooFilePath" - assertRelativelyTheSame b "non-cabal-appdir/snaplets/foosnaplet" + assertRelativelyTheSame b "snaplets/foosnaplet" ------------------------------------------------------------------------------ +assertRelativelyTheSame :: FilePath -> FilePath -> IO () +assertRelativelyTheSame p expected = do + b <- makeRelativeToCurrentDirectory p + assertEqual ("expected " ++ expected) expected b + + +------------------------------------------------------------------------------ +grab :: MonadIO m => String -> m L.ByteString +grab path = liftIO $ liftM (L.fromChunks . (:[])) $ + get (S.pack $ testServerUri ++ path) concatHandler + + +------------------------------------------------------------------------------ testWithCwd :: String -> (String -> L.ByteString -> Assertion) -> Test @@ -81,7 +165,7 @@ f cwd b where - slashUri = "/" ++ uri + slashUri = '/' : uri ------------------------------------------------------------------------------ @@ -89,7 +173,7 @@ fooHandlerConfigTest = testWithCwd "foo/handlerConfig" $ \cwd b -> do let response = L.fromChunks [ "([\"app\"],\"" , S.pack cwd - , "/non-cabal-appdir/snaplets/foosnaplet\"," + , "/snaplets/foosnaplet\"," , "Just \"foosnaplet\",\"A demonstration " , "snaplet called foo.\",\"foo\")" ] assertEqual "" response b @@ -100,7 +184,7 @@ barHandlerConfigTest = testWithCwd "bar/handlerConfig" $ \cwd b -> do let response = L.fromChunks [ "([\"app\"],\"" , S.pack cwd - , "/non-cabal-appdir/snaplets/baz\"," + , "/snaplets/baz\"," , "Just \"baz\",\"An example snaplet called " , "bar.\",\"\")" ] assertEqual "" response b @@ -112,10 +196,10 @@ bazpage5Test = testWithCwd "bazpage5" $ \cwd b -> do let response = L.fromChunks [ "baz template page ([\"app\"],\"" , S.pack cwd - , "/non-cabal-appdir/snaplets/baz\"," + , "/snaplets/baz\"," , "Just \"baz\",\"An example snaplet called " , "bar.\",\"\")\n" ] - assertEqual "" response b + assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b) ------------------------------------------------------------------------------ @@ -127,29 +211,25 @@ let response = L.fromChunks [ "baz config page ([],\"" , S.pack cwd - , "/non-cabal-appdir\",Just \"app\"," + , "\",Just \"app\"," -- TODO, right? , "\"Test application\",\"\") " , "([\"app\"],\"" , S.pack cwd - , "/non-cabal-appdir/snaplets/foosnaplet\"," + , "/snaplets/foosnaplet\"," , "Just \"foosnaplet\",\"A demonstration snaplet " , "called foo.\",\"foo\")\n" ] - assertEqual "" response b + assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b) ------------------------------------------------------------------------------ expect404 :: String -> IO () -expect404 url = action `catch` h - where - action = do - HTTP.simpleHttp $ "http://127.0.0.1:9753/" ++ url - assertFailure "expected 404" - - h e@(HTTP.StatusCodeException c _) | c == 404 = return () - | otherwise = throwIO e - h e = throwIO e +expect404 url = do + get (S.pack $ testServerUrl ++ url) $ \resp i -> do + case getStatusCode resp of + 404 -> return () + _ -> assertFailure "expected 404" ------------------------------------------------------------------------------ @@ -157,66 +237,6 @@ request404Test url = testCase (testName url) $ expect404 url ------------------------------------------------------------------------------- -requestTest' :: String -> Text -> IO () -requestTest' url desired = do - actual <- HTTP.simpleHttp $ "http://127.0.0.1:9753/" ++ url - assertEqual url desired (T.decodeUtf8 actual) - - ------------------------------------------------------------------------------- -requestNoError :: String -> Text -> Test -requestNoError url desired = - testCase (testName url) $ requestNoError' url desired - - ------------------------------------------------------------------------------- -requestNoError' :: String -> Text -> IO () -requestNoError' url desired = do - let fullUrl = "http://127.0.0.1:9753/" ++ url - url' <- HTTP.parseUrl fullUrl - HTTP.Response _ _ b <- liftIO $ HTTP.withManager $ HTTP.httpLbsRedirect url' - assertEqual fullUrl desired (T.decodeUtf8 b) - - ------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "non-cabal-tests" - [ requestTest "hello" "hello world" - , requestTest "index" "index page\n" - , requestTest "" "index page\n" - , requestTest "splicepage" "splice page contents of the app splice\n" - , requestTest "routeWithSplice" "routeWithSplice: foo snaplet data stringz" - , requestTest "routeWithConfig" "routeWithConfig: topConfigValue" - , requestTest "foo/foopage" "foo template page\n" - , requestTest "foo/fooConfig" "fooValue" - , requestTest "foo/fooRootUrl" "foo" - , requestTest "barconfig" "barValue" - , requestTest "bazpage" "baz template page \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" - , requestNoError "bazbadpage" "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found." - , requestTest "foo/fooSnapletName" "foosnaplet" - - , fooConfigPathTest - - -- Test the embedded snaplet - , requestTest "embed/heist/embeddedpage" "embedded snaplet page \n" - , requestTest "embed/aoeuhtns" "embedded snaplet page splice value42\n" - , requestTest "embed/heist/onemoredir/extra" "This is an extra template\n" - - -- This set of tests highlights the differences in the behavior of the - -- get... functions from MonadSnaplet. - , fooHandlerConfigTest - , barHandlerConfigTest - , bazpage5Test - , bazConfigTest - , requestTest "sessionDemo" "[(\"foo\",\"bar\")]\n" - , reloadTest - ] - remove :: FilePath -> IO () remove f = do exists <- doesFileExist f @@ -226,84 +246,95 @@ removeDir :: FilePath -> IO () removeDir d = do exists <- doesDirectoryExist d - when exists $ removeDirectoryRecursive "non-cabal-appdir/snaplets/foosnaplet" + when exists $ removeDirectoryRecursive "snaplets/foosnaplet" ------------------------------------------------------------------------------ reloadTest :: Test reloadTest = testCase "internal/reload-test" $ do - let goodTplOrig = "non-cabal-appdir" "good.tpl" - let badTplOrig = "non-cabal-appdir" "bad.tpl" - let goodTplNew = "non-cabal-appdir" "snaplets" "heist" - "templates" "good.tpl" - let badTplNew = "non-cabal-appdir" "snaplets" "heist" - "templates" "bad.tpl" + let goodTplOrig = "good.tpl" + let badTplOrig = "bad.tpl" + let goodTplNew = "snaplets" "heist" + "templates" "good.tpl" + let badTplNew = "snaplets" "heist" + "templates" "bad.tpl" goodExists <- doesFileExist goodTplNew badExists <- doesFileExist badTplNew assertBool "good.tpl exists" (not goodExists) - assertBool "bad.tpl exists" (not badExists) + assertBool "bad.tpl exists" (not badExists) expect404 "bad" copyFile badTplOrig badTplNew expect404 "good" expect404 "bad" - testWithCwd' "admin/reload" $ \cwd' b -> do - let cwd = S.pack cwd' - let response = - L.fromChunks [ "Error reloading site!\n\nInitializer " - , "threw an exception...\n" - , cwd - , "/non-cabal-appdir/snaplets/heist" - , "/templates/bad.tpl \"" - , cwd - , "/non-cabal-appdir/snaplets/heist/templates" - , "/bad.tpl\" (line 2, column 1):\nunexpected " - , "end of input\nexpecting \"=\", \"/\" or " - , "\">\"\n\n\n...but before it died it generated " - , "the following output:\nInitializing app @ /\n" - , "Initializing heist @ /heist\n\n" ] - assertEqual "admin/reload" response b + flip finally (remove badTplNew) $ + testWithCwd' "admin/reload" $ \cwd' b -> do + let cwd = T.pack cwd' - remove badTplNew + let prefix = T.intercalate "\n" + [ "Error reloading site!" + , "" + , "Initializer threw an exception..." + , T.concat + [ cwd, "/snaplets/heist/templates/bad.tpl \"" + , cwd, "/snaplets/heist/templates/bad.tpl\" (line 2, column 1):" + ] + , "unexpected end of input" + , "expecting \"=\", \"/\" or \">\"" + + -- Building with the latest dependency versions produces the following: + -- "CallStack (from HasCallStack):" + -- " error, called at src/Snap/Snaplet/Heist/Internal.hs:75:35 in main:Snap.Snaplet.Heist.Internal" + ] + + let suffix = T.intercalate "\n" + [ "...but before it died it generated the following output:" + , "Initializing app @ /" + , "Initializing heist @ /heist" + , "" + , "" + ] + + let response = T.decodeUtf8 b + + assertEqual "admin/reload" prefix (T.take (T.length prefix) response) + assertEqual "admin/reload" suffix (T.takeEnd (T.length suffix) response) + copyFile goodTplOrig goodTplNew - testWithCwd' "admin/reload" $ \cwd' b -> do + testWithCwd' "admin/reload" $ \cwd' b -> do -- TODO/NOTE: Needs cleanup let cwd = S.pack cwd' - let response = - L.fromChunks [ "Initializing app @ /\n" - , "Initializing heist @ /heist\n" - , "...loaded 5 templates from " - , cwd - , "/non-cabal-appdir/snaplets/heist/templates\n" - , "Initializing foosnaplet @ /foo\n" - , "...adding 1 templates from " - , cwd - , "/non-cabal-appdir/snaplets/foosnaplet" - , "/templates with route prefix foo/\n" - , "Initializing baz @ /\n" - , "...adding 2 templates from " - , cwd - , "/non-cabal-appdir/snaplets/baz/templates " - , "with route prefix /\n" - , "Initializing CookieSession @ /session\n" - , "Initializing embedded @ /\n" - , "Initializing heist @ /heist\n" - , "...loaded 1 templates from " - , cwd - , "/non-cabal-appdir/snaplets/embedded" - , "/snaplets/heist/templates\n" - , "...adding 1 templates from " - , cwd - , "/non-cabal-appdir/snaplets/embedded" - , "/extra-templates with route prefix " - , "onemoredir/\n" - , "Site successfully reloaded.\n" - ] + let response = L.fromChunks [ + "Initializing app @ /\nInitializing heist @ ", + "/heist\n...loaded 9 templates from ", + cwd, + "/snaplets/heist/templates\nInitializing CookieSession ", + "@ /session\nInitializing foosnaplet @ /foo\n...adding 1 ", + "templates from ", + cwd, + "/snaplets/foosnaplet/templates with route prefix ", + "foo/\nInitializing baz @ /\n...adding 2 templates from ", + cwd, + "/snaplets/baz/templates with route prefix /\nInitializing ", + "embedded @ /\nInitializing heist @ /heist\n...loaded ", + "1 templates from ", + cwd, + "/snaplets/embedded/snaplets/heist/templates\n...adding ", + "1 templates from ", + cwd, + "/snaplets/embedded/extra-templates with route prefix ", + "onemoredir/\n...adding 0 templates from ", + cwd, + "/templates with route prefix extraTemplates/\n", + "Initializing JsonFileAuthManager @ ", + "/auth\nSite successfully reloaded.\n" + ] assertEqual "admin/reload" response b requestTest' "good" "Good template\n" + diff --git a/test/suite/Blackbox/Types.hs b/test/suite/Blackbox/Types.hs deleted file mode 100644 --- a/test/suite/Blackbox/Types.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Blackbox.Types where - - -import Data.Lens.Template - -import Snap.Snaplet -import Snap.Snaplet.Heist - -import Blackbox.FooSnaplet -import Blackbox.BarSnaplet -import Blackbox.EmbeddedSnaplet -import Snap.Snaplet.Session - - -data App = App - { _heist :: Snaplet (Heist App) - , _foo :: Snaplet FooSnaplet - , _bar :: Snaplet (BarSnaplet App) - , _session :: Snaplet SessionManager - , _embedded :: Snaplet EmbeddedSnaplet - } - -makeLenses [''App] - -instance HasHeist App where heistLens = subSnaplet heist - diff --git a/test/suite/NestTest.hs b/test/suite/NestTest.hs deleted file mode 100644 --- a/test/suite/NestTest.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Main where - -import Prelude hiding ((.)) -import Control.Monad.State -import Data.Lens.Lazy -import Data.Lens.Template -import qualified Data.Text as T -import Snap.Http.Server.Config -import Snap.Core -import Snap.Util.FileServe - -import Snap.Snaplet -import Snap.Snaplet.Heist -import Text.Templating.Heist - --- If we universally quantify FooSnaplet to get rid of the type parameter --- mkLabels throws an error "Can't reify a GADT data constructor" -data FooSnaplet = FooSnaplet - { _fooHeist :: Snaplet (Heist FooSnaplet) - , _fooVal :: Int - } - -makeLenses [''FooSnaplet] - -instance HasHeist FooSnaplet where - heistLens = subSnaplet fooHeist - -fooInit :: SnapletInit FooSnaplet FooSnaplet -fooInit = makeSnaplet "foosnaplet" "foo snaplet" Nothing $ do - hs <- nestSnaplet "heist" fooHeist $ heistInit "templates" - addTemplates "foo" - rootUrl <- getSnapletRootURL - fooLens <- getLens - addRoutes [("fooRootUrl", writeBS rootUrl) - ,("aoeuhtns", renderWithSplices "foo/foopage" - [("asplice", fooSplice fooLens)]) - ,("", heistServe) - ] - return $ FooSnaplet hs 42 - - ---fooSplice :: (Lens (Snaplet b) (Snaplet (FooSnaplet b))) --- -> SnapletSplice (Handler b b) -fooSplice :: (Lens (Snaplet b) (Snaplet FooSnaplet)) - -> SnapletHeist b v Template -fooSplice fooLens = do - val <- liftWith fooLens $ gets _fooVal - liftHeist $ textSplice $ T.pack $ "splice value" ++ (show val) - ------------------------------------------------------------------------------- - -data App = App - { _foo :: Snaplet (FooSnaplet) - } - -makeLenses [''App] - -app :: SnapletInit App App -app = makeSnaplet "app" "nested snaplet application" Nothing $ do - fs <- embedSnaplet "foo" foo fooInit - addRoutes [ ("/hello", writeText "hello world") - , ("/public", serveDirectory "public") - ] - return $ App fs - -main :: IO () -main = serveSnaplet defaultConfig app - diff --git a/test/suite/SafeCWD.hs b/test/suite/SafeCWD.hs --- a/test/suite/SafeCWD.hs +++ b/test/suite/SafeCWD.hs @@ -11,7 +11,9 @@ sem :: QSem sem = unsafePerformIO $ newQSem 1 +{-# NOINLINE sem #-} + inDir :: Bool -> FilePath -> IO a -> IO a inDir startClean dir action = bracket before after (const action) where @@ -25,6 +27,7 @@ after cwd = do setCurrentDirectory cwd signalQSem sem + removeDirectoryRecursiveSafe p = doesDirectoryExist p >>= flip when (removeDirectoryRecursive p) 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 --- a/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs @@ -2,11 +2,11 @@ module Snap.Snaplet.Internal.LensT.Tests (tests) where +import Control.Lens import Control.Applicative import Control.Category import Control.Monad.Identity import Control.Monad.State.Strict -import Data.Lens.Template import Prelude hiding (catch, (.)) import Test.Framework import Test.Framework.Providers.HUnit @@ -33,7 +33,9 @@ _bot0 :: Int } deriving (Show) -makeLenses [''TestType, ''TestSubType, ''TestBotType] +makeLenses ''TestType +makeLenses ''TestSubType +makeLenses ''TestBotType ------------------------------------------------------------------------------ @@ -54,10 +56,10 @@ testfmap :: Test testfmap = testCase "lensed/fmap" $ do -- x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState - let x = fst $ runIdentity (runLensT (fmap (*2) three) (bot . sub) defaultState) + let x = fst $ runIdentity (runLensT (fmap (*2) three) (sub . bot) defaultState) assertEqual "fmap" 6 x - let (y,s') = runIdentity (runLensT twiddle (bot . sub) defaultState) + let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState) assertEqual "fmap2" (12 :: Int) y assertEqual "lens" (13 :: Int) $ _bot0 $ _bot $ _sub s' @@ -76,10 +78,10 @@ testApplicative :: Test testApplicative = testCase "lensed/applicative" $ do -- x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState - let x = fst $ runIdentity (runLensT (pure (*2) <*> three) (bot . sub) defaultState) + let x = fst $ runIdentity (runLensT (pure (*2) <*> three) (sub . bot) defaultState) assertEqual "fmap" 6 x - let (y,s') = runIdentity (runLensT twiddle (bot . sub) defaultState) + let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState) assertEqual "fmap2" (12::Int) y assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s' @@ -98,7 +100,7 @@ testMonadState :: Test testMonadState = testCase "lens/MonadState" $ do -- s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState - let s = snd $ runIdentity (runLensT go (bot0 . bot . sub) defaultState) + let s = snd $ runIdentity (runLensT go (sub . bot . bot0) defaultState) assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s assertEqual "sub0" 3 $ _sub0 $ _sub s diff --git a/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs b/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs --- a/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs @@ -5,8 +5,8 @@ import Control.Applicative import Control.Category import Control.Exception -import Control.Monad.State.Strict -import Data.Lens.Template +import Control.Lens +import Control.Monad.State.Lazy import Prelude hiding (catch, (.)) import Test.Framework import Test.Framework.Providers.HUnit @@ -33,7 +33,9 @@ _bot0 :: Int } deriving (Show) -makeLenses [''TestType, ''TestSubType, ''TestBotType] +makeLenses ''TestType +makeLenses ''TestSubType +makeLenses ''TestBotType ------------------------------------------------------------------------------ @@ -52,10 +54,10 @@ ------------------------------------------------------------------------------ testfmap :: Test testfmap = testCase "lensed/fmap" $ do - x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState + x <- evalStateT (lensedAsState (fmap (*2) three) (sub . bot)) defaultState assertEqual "fmap" 6 x - (y,s') <- runStateT (lensedAsState twiddle (bot . sub)) defaultState + (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState assertEqual "fmap2" 12 y assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s' @@ -73,10 +75,10 @@ ------------------------------------------------------------------------------ testApplicative :: Test testApplicative = testCase "lensed/applicative" $ do - x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState + x <- evalStateT (lensedAsState (pure (*2) <*> three) (sub . bot)) defaultState assertEqual "fmap" 6 x - (y,s') <- runStateT (lensedAsState twiddle (bot . sub)) defaultState + (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState assertEqual "fmap2" (12::Int) y assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s' @@ -94,7 +96,7 @@ ------------------------------------------------------------------------------ testMonadState :: Test testMonadState = testCase "lens/MonadState" $ do - s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState + s <- execStateT (lensedAsState go (sub . bot . bot0)) defaultState assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s assertEqual "sub0" 3 $ _sub0 $ _sub s diff --git a/test/suite/Snap/Snaplet/Internal/RST/Tests.hs b/test/suite/Snap/Snaplet/Internal/RST/Tests.hs --- a/test/suite/Snap/Snaplet/Internal/RST/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/RST/Tests.hs @@ -16,7 +16,7 @@ import Test.Framework.Providers.QuickCheck2 import Test.HUnit hiding (Test, path) -import Snap.Snaplet.Internal.RST +import Snap.Snaplet.Internal.RST tests :: Test diff --git a/test/suite/Snap/Snaplet/Internal/Tests.hs b/test/suite/Snap/Snaplet/Internal/Tests.hs --- a/test/suite/Snap/Snaplet/Internal/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/Tests.hs @@ -7,17 +7,18 @@ ( tests, initTest ) where ------------------------------------------------------------------------------ -import Control.Monad -import Control.Monad.Trans -import Data.ByteString (ByteString) -import Data.Lens.Template -import Data.List -import Data.Text -import Prelude hiding (catch, (.)) -import System.Directory -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test, path) +import Control.Lens (makeLenses) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Text (Text) +import Prelude hiding (catch, (.)) +import System.Directory (getCurrentDirectory) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.SmallCheck (testProperty) +import Test.HUnit hiding (Test, path) +import Test.SmallCheck ((==>)) ------------------------------------------------------------------------------ import Snap.Snaplet.Internal.Initializer import Snap.Snaplet.Internal.Types @@ -39,7 +40,7 @@ , _bar :: Snaplet Bar } -makeLens ''App +makeLenses ''App --showConfig :: SnapletConfig -> IO () --showConfig c = do @@ -79,6 +80,9 @@ configAssertions "root " ([], cwd, Just "app", "Test application", "") + + assertGet "environment" getEnvironment "devel" + f <- nestSnaplet "foo" foo $ fooInit b <- nestSnaplet "bar" bar $ barInit return $ App f b @@ -108,7 +112,7 @@ ------------------------------------------------------------------------------ initTest :: IO () initTest = do - (out,_,_) <- runSnaplet appInit + (out,_,_) <- runSnaplet Nothing appInit -- note from gdc: wtf? if out == "aoeu" @@ -120,5 +124,13 @@ tests :: Test tests = testGroup "Snap.Snaplet.Internal" [ testCase "initializer tests" initTest + , testProperty "buildPath generates no double slashes" doubleSlashes ] + +--doubleSlashes :: Monad m => [String] -> Property m +doubleSlashes arrStr = noSlashes ==> not (B.isInfixOf "//" $ buildPath arr) + where + arr = map B.pack arrStr + noSlashes = not $ or $ map (B.elem '/') arr + 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,143 +1,82 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module Snap.TestCommon where ------------------------------------------------------------------------------ -import Control.Concurrent ( threadDelay ) -import Control.Exception ( ErrorCall(..) - , SomeException - , bracket - , catch - , throwIO - ) -import Control.Monad ( forM_ ) -import Data.Maybe ( fromMaybe ) -import Data.Monoid ( First(..), mconcat ) -import Prelude hiding ( catch ) -import System.Cmd ( system ) -import System.Directory ( doesFileExist - , getCurrentDirectory - , findExecutable - , removeFile - ) -import System.Environment ( getEnv ) -import System.Exit ( ExitCode(..) ) -import System.FilePath ( joinPath, splitPath, () ) -import System.FilePath.Glob ( compile, globDir1 ) -import System.Process ( runCommand - , terminateProcess - , waitForProcess - ) - +import Control.Exception (try, SomeException) +import Control.Monad.Trans (lift) +import qualified Data.Text as T +import qualified GHC.Read as R +import Test.HUnit (Assertion, assertFailure, assertBool) +import qualified Text.ParserCombinators.ReadPrec as R ------------------------------------------------------------------------------ -import SafeCWD +import Snap.Core +import Snap.Snaplet +import Snap.Snaplet.Heist +import Heist.Interpreted ------------------------------------------------------------------------------ -testGeneratedProject :: String -- ^ project name and directory - -> String -- ^ arguments to @snap init@ - -> String -- ^ arguments to @cabal install@ - -> Int -- ^ port to run http server on - -> IO () -- ^ action to run when the server goes up - -> IO () -testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort - testAction = do - cwd <- getCurrentDirectory +expectException :: String -> IO a -> IO () +expectException s m = do + r <- try m + case r of + Left (e::SomeException) -> length (show e) `seq` return () + Right _ -> assertFailure s - -------------------------------------------------------------------------- - let segments = reverse $ splitPath cwd - projectPath = cwd "test-snap-exe" projName - snapRoot = joinPath $ reverse $ drop 1 segments - snapRepos = joinPath $ reverse $ drop 2 segments - sandbox = cwd "test-cabal-dev" - cabalDevArgs = "-s " ++ sandbox - args = cabalDevArgs ++ " --reinstall " ++ cabalInstallArgs - ---------------------------------------------------------------------- - initialize = do - snapExe <- findSnap - systemOrDie $ snapExe ++ " init " ++ snapInitArgs - - snapCoreSrc <- fromEnv "SNAP_CORE_SRC" $ - snapRepos "snap-core" - snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $ - snapRepos "snap-server" - xmlhtmlSrc <- fromEnv "XMLHTML_SRC" $ snapRepos "xmlhtml" - heistSrc <- fromEnv "HEIST_SRC" $ snapRepos "heist" - let snapSrc = snapRoot - - forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap" ] - (pkgCleanUp sandbox) - - forM_ [ snapCoreSrc, snapServerSrc, xmlhtmlSrc, heistSrc - , snapSrc] $ \s -> - systemOrDie $ concat [ "cabal-dev " - , cabalDevArgs - , " add-source " - , s - ] - - systemOrDie $ "cabal-dev install " ++ args - let cmd = ("." "dist" "build" projName projName) - ++ " -p " ++ show httpPort - putStrLn $ "Running \"" ++ cmd ++ "\"" - pHandle <- runCommand cmd - waitABit - return pHandle - - ---------------------------------------------------------------------- - findSnap = do - home <- fromEnv "HOME" "." - p1 <- gimmeIfExists $ snapRoot "dist" "build" - "snap" "snap" - p2 <- gimmeIfExists $ home ".cabal" "bin" "snap" - p3 <- findExecutable "snap" - - return $ fromMaybe (error "couldn't find snap executable") - (getFirst $ mconcat $ map First [p1,p2,p3]) +------------------------------------------------------------------------------ +showTestCase :: Show a => a -> Assertion +showTestCase a = assertBool "Show instance failed" $ + ((showsPrec 5 a) "" == show a) + && (showList [a]) "" == "[" ++ show a ++ "]" + - -------------------------------------------------------------------------- - putStrLn $ "Changing directory to " ++ projectPath - inDir True projectPath $ bracket initialize cleanup (const testAction) - removeDirectoryRecursiveSafe projectPath +------------------------------------------------------------------------------ +readTestCase :: (Eq a, Show a, Read a) => a -> Assertion +readTestCase a = assertBool "Read instance failed" $ + ( ((readsPrec 1) (show a)) == ([(a,"")])) + && ((readList ("[" ++ show a ++ "]")) == [([a],"")]) + && ((R.readPrec_to_S (R.readPrec) 5) (show a) == [(a,"")]) + && ((R.readPrec_to_S (R.readListPrec) 5) ("[" ++ show a ++ "]") + == [([a],"")]) + +------------------------------------------------------------------------------ +ordTestCase :: (Eq a, Ord a) => a -> a -> Assertion +ordTestCase a b = assertBool "Ord instance failed" $ + low <= high + && (if low /= high + then low < high && compare low high == LT && high > low + else low == high && compare low high == EQ) where - -------------------------------------------------------------------------- - fromEnv name def = do - r <- getEnv name `catch` \(_::SomeException) -> return "" - if r == "" then return def else return r + low = min a b + high = max a b - -------------------------------------------------------------------------- - cleanup pHandle = do - terminateProcess pHandle - waitForProcess pHandle - -------------------------------------------------------------------------- - waitABit = threadDelay $ 2*10^(6::Int) +------------------------------------------------------------------------------ +eqTestCase :: (Eq a) => a -> a -> Assertion +eqTestCase a b = assertBool "Eq instance failed" $ + if a == b + then (a /= b) == False + else (a /= b) == True - -------------------------------------------------------------------------- - pkgCleanUp d pkg = do - paths <- globDir1 (compile $ "packages*conf/" ++ pkg ++ "-*") d - forM_ paths $ \x -> - rm x `catch` \(_::SomeException) -> return () - where - rm x = do - putStrLn $ "removing " ++ x - removeFile x +------------------------------------------------------------------------------ +genericConfigString :: (MonadSnaplet m, Monad (m b v)) => m b v T.Text +genericConfigString = do + a <- getSnapletAncestry + b <- getSnapletFilePath + c <- getSnapletName + d <- getSnapletDescription + e <- getSnapletRootURL + return $ T.pack $ show (a,b,c,d,e) - -------------------------------------------------------------------------- - gimmeIfExists p = do - b <- doesFileExist p - if b then return (Just p) else return Nothing +------------------------------------------------------------------------------ +handlerConfig :: Handler b v () +handlerConfig = writeText =<< genericConfigString + ------------------------------------------------------------------------------ -systemOrDie :: String -> IO () -systemOrDie s = do - putStrLn $ "Running \"" ++ s ++ "\"" - system s >>= check +shConfigSplice :: SnapletLens (Snaplet b) v -> SnapletISplice b +shConfigSplice _lens = textSplice =<< lift (with' _lens genericConfigString) - where - check ExitSuccess = return () - check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'" diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -5,57 +5,69 @@ ------------------------------------------------------------------------------ import Control.Concurrent -import Control.Exception -import Control.Monad -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Char8 as S -import qualified Network.HTTP.Enumerator as HTTP -import Prelude hiding (catch) -import Snap.Http.Server.Config -import Snap.Snaplet +import Control.Exception (SomeException (..), bracket, catch, finally) +import Control.Monad (void) +import System.Directory (getCurrentDirectory, setCurrentDirectory) +import System.FilePath (()) import System.IO -import System.Posix.Process -import System.Posix.Signals -import System.Posix.Types -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test, path) + ------------------------------------------------------------------------------ -import Blackbox.App import qualified Blackbox.Tests -import Snap.Http.Server (simpleHttpServe) +import Prelude (Bool (False), IO, Int, Maybe (Nothing), Monad (..), Num (..), flip, return, ($), (.), (^)) +import Snap.Http.Server (simpleHttpServe) +import Snap.Http.Server.Config +import Snap.Snaplet +import qualified Snap.Snaplet.Auth.Tests +import qualified Snap.Snaplet.Config.Tests +import qualified Snap.Snaplet.Heist.Tests import qualified Snap.Snaplet.Internal.Lensed.Tests import qualified Snap.Snaplet.Internal.LensT.Tests import qualified Snap.Snaplet.Internal.RST.Tests import qualified Snap.Snaplet.Internal.Tests -import Snap.TestCommon +import Snap.Snaplet.Test.Common.App +import qualified Snap.Snaplet.Test.Tests +import Test.Framework import SafeCWD - ------------------------------------------------------------------------------ main :: IO () main = do + -- chdir into test/ + cwd <- getCurrentDirectory + setCurrentDirectory (cwd "test") + Blackbox.Tests.remove - "non-cabal-appdir/snaplets/heist/templates/bad.tpl" + "snaplets/heist/templates/bad.tpl" Blackbox.Tests.remove - "non-cabal-appdir/snaplets/heist/templates/good.tpl" - Blackbox.Tests.removeDir "non-cabal-appdir/snaplets/foosnaplet" + "snaplets/heist/templates/good.tpl" + {- Why were we removing this? + Blackbox.Tests.removeDir "snaplets/foosnaplet" + -} - (tid, mvar) <- inDir False "non-cabal-appdir" startServer - defaultMain [tests] `finally` killThread tid +-- (tid, mvar) <- inDir False "non-cabal-appdir" startServer + (tid, mvar) <- inDir False "." startServer - putStrLn "waiting for termination mvar" - takeMVar mvar + defaultMain [tests] + `finally` do + setCurrentDirectory cwd + killThread tid + putStrLn "waiting for termination mvar" + takeMVar mvar - where tests = mutuallyExclusive $ + where tests = mutuallyExclusive $ testGroup "snap" [ internalServerTests - , testDefault - , testBarebones - , testTutorial + , Snap.Snaplet.Auth.Tests.tests + , Snap.Snaplet.Test.Tests.tests + , Snap.Snaplet.Heist.Tests.heistTests + , Snap.Snaplet.Config.Tests.configTests + , Snap.Snaplet.Internal.RST.Tests.tests + , Snap.Snaplet.Internal.LensT.Tests.tests + , Snap.Snaplet.Internal.Lensed.Tests.tests ] + ------------------------------------------------------------------------------ internalServerTests :: Test internalServerTests = @@ -73,71 +85,21 @@ startServer :: IO (ThreadId, MVar ()) startServer = do mvar <- newEmptyMVar - t <- forkIO $ serve mvar (setPort 9753 defaultConfig) app + t <- forkIOWithUnmask $ \restore -> + serve restore mvar (setPort 9753 . + setBind "127.0.0.1" $ defaultConfig) appInit threadDelay $ 2*10^(6::Int) return (t, mvar) where - serve mvar config initializer = + gobble m = void m `catch` \(_::SomeException) -> return () + serve restore mvar config initializer = flip finally (putMVar mvar ()) $ - handle handleErr $ do + gobble $ restore $ do hPutStrLn stderr "initializing snaplet" - (_, handler, doCleanup) <- runSnaplet initializer - - flip finally doCleanup $ do - (conf, site) <- combineConfig config handler - hPutStrLn stderr "bringing up server" - simpleHttpServe conf site - hPutStrLn stderr "server killed" - - handleErr :: SomeException -> IO () - handleErr e = hPutStrLn stderr $ "startServer exception: " ++ show e - - ------------------------------------------------------------------------------- -testBarebones :: Test -testBarebones = testCase "snap/barebones" go - where - go = testGeneratedProject "barebonesTest" - "barebones" - "" - port - testIt - port = 9990 :: Int - testIt = do - body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port) - assertEqual "server not up" "hello world" body - - ------------------------------------------------------------------------------- -testDefault :: Test -testDefault = testCase "snap/default" go - where - go = testGeneratedProject "defaultTest" - "" - "" - port - testIt - port = 9991 :: Int - testIt = do - body <- liftM (S.concat . L.toChunks) $ - HTTP.simpleHttp $ "http://127.0.0.1:"++(show port) - assertBool "response contains phrase 'it works!'" - $ "It works!" `S.isInfixOf` body - - ------------------------------------------------------------------------------- -testTutorial :: Test -testTutorial = testCase "snap/tutorial" go - where - go = testGeneratedProject "tutorialTest" - "tutorial" - "" - port - testIt - port = 9992 :: Int - testIt = do - body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)++"/hello" - assertEqual "server not up" "hello world" body - - + bracket (runSnaplet Nothing initializer) + (\(_, _, doCleanup) -> doCleanup) + (\(_, handler, _ ) -> do + (conf, site) <- combineConfig config handler + hPutStrLn stderr "bringing up server" + simpleHttpServe conf site)