Merge branch 'snaplet-test' of https://github.com/adinapoli/snap into…

… 0.10

Conflicts:
	snap.cabal

.gitignore

@@ -15,6 +15,8 @@ dist*/
 docs/templates/out
 sitekey.txt
 test/dist*
+test/*.json
 test/test-cabal-dev
 test/test-snap-exe
 test/dist/snaplets
+test/non-cabal-appdir/snaplets/foosnaplet

snap.cabal

@@ -113,6 +113,7 @@ Library
     Snap.Snaplet.Session.Common
     Snap.Snaplet.Session.SessionManager
     Snap.Snaplet.Session.Backends.CookieSession
+    Snap.Snaplet.Test
 
   other-modules:
     Control.Access.RoleBased.Checker
@@ -126,7 +127,6 @@ Library
     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
@@ -157,6 +157,7 @@ Library
     mtl                       >  2.0      && < 2.2,
     mwc-random                >= 0.8      && < 0.13,
     pwstore-fast              >= 2.2      && < 2.4,
+    regex-posix               >= 0.95    && < 1,
     snap-core                 >= 0.9.2    && < 0.10,
     snap-server               >= 0.9.2    && < 0.10,
     stm                       >= 2.2      && < 2.5,

snap.cabal.orig

@@ -0,0 +1,233 @@
+name:           snap
+version:        0.10.0
+synopsis:       Top-level package for the Snap Web Framework
+description:
+    This is the top-level package for the official Snap Framework libraries.
+    It includes:
+    .
+    * The Snaplets API
+    .
+    * The \"snap\" executable program for generating starter projects
+    .
+    * Snaplets for sessions, authentication, and templates
+    .
+    To get started, issue the following sequence of commands:
+    .
+    @$ cabal install snap
+    $ mkdir myproject
+    $ cd myproject
+    $ snap init@
+    .
+    If you have trouble or any questions, see our FAQ page
+    (<http://snapframework.com/faq>) or the documentation
+    (<http://snapframework.com/docs>).
+
+license:        BSD3
+license-file:   LICENSE
+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/
+category:       Web, Snap
+
+extra-source-files:
+  CONTRIBUTORS,
+  LICENSE,
+  README.md,
+  README.SNAP.md,
+  project_template/barebones/.ghci,
+  project_template/barebones/foo.cabal,
+  project_template/barebones/log/access.log,
+  project_template/barebones/src/Main.hs,
+  project_template/default/.ghci,
+  project_template/default/foo.cabal,
+  project_template/default/log/access.log,
+  project_template/default/log/error.log,
+  project_template/default/static/screen.css,
+  project_template/default/snaplets/heist/templates/base.tpl,
+  project_template/default/snaplets/heist/templates/index.tpl,
+  project_template/default/snaplets/heist/templates/_login.tpl,
+  project_template/default/snaplets/heist/templates/login.tpl,
+  project_template/default/snaplets/heist/templates/_new_user.tpl,
+  project_template/default/snaplets/heist/templates/new_user.tpl,
+  project_template/default/snaplets/heist/templates/userform.tpl,
+  project_template/default/src/Application.hs,
+  project_template/default/src/Main.hs,
+  project_template/default/src/Site.hs,
+  project_template/tutorial/.ghci,
+  project_template/tutorial/foo.cabal,
+  project_template/tutorial/log/placeholder,
+  project_template/tutorial/src/Part2.lhs,
+  project_template/tutorial/src/Tutorial.lhs,
+  extra/hscolour.css,
+  extra/haddock.css,
+  extra/logo.gif,
+  test/snap-testsuite.cabal,
+  test/runTestsAndCoverage.sh,
+  test/suite/TestSuite.hs,
+  test/suite/NestTest.hs,
+  test/suite/Snap/TestCommon.hs,
+  test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs,
+  test/suite/Snap/Snaplet/Internal/RST/Tests.hs,
+  test/suite/Snap/Snaplet/Internal/Tests.hs,
+  test/suite/Snap/Snaplet/Internal/LensT/Tests.hs,
+  test/suite/Blackbox/Types.hs,
+  test/suite/Blackbox/FooSnaplet.hs,
+  test/suite/Blackbox/BarSnaplet.hs,
+  test/suite/Blackbox/Common.hs,
+  test/suite/Blackbox/EmbeddedSnaplet.hs,
+  test/suite/Blackbox/Tests.hs,
+  test/suite/Blackbox/App.hs,
+  test/suite/SafeCWD.hs,
+  test/suite/AppMain.hs,
+  test/non-cabal-appdir/db.cfg,
+  test/non-cabal-appdir/bad.tpl,
+  test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl,
+  test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl,
+  test/non-cabal-appdir/snaplets/baz/devel.cfg,
+  test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl,
+  test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl,
+  test/non-cabal-appdir/snaplets/heist/templates/index.tpl,
+  test/non-cabal-appdir/snaplets/heist/templates/session.tpl,
+  test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl,
+  test/non-cabal-appdir/snaplets/heist/templates/page.tpl,
+  test/non-cabal-appdir/good.tpl,
+  test/non-cabal-appdir/log/placeholder,
+  test/non-cabal-appdir/devel.cfg,
+  test/foosnaplet/templates/foopage.tpl,
+  test/foosnaplet/devel.cfg
+
+Library
+  hs-source-dirs: src
+
+  exposed-modules:
+    Snap,
+    Snap.Snaplet
+    Snap.Snaplet.Heist
+    Snap.Snaplet.HeistNoClass
+    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.Internal.Initializer
+    Snap.Snaplet.Internal.LensT
+    Snap.Snaplet.Internal.Lensed
+    Snap.Snaplet.Internal.RST
+    Snap.Snaplet.Internal.Types
+    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.11,
+    cereal                    >= 0.3      && < 0.4,
+    clientsession             >= 0.8      && < 0.9,
+    configurator              >= 0.1      && < 0.3,
+    comonad                   >= 1.1      && < 3.1,
+    containers                >= 0.3      && < 0.6,
+    directory                 >= 1.0      && < 1.3,
+    directory-tree            >= 0.10     && < 0.12,
+    dlist                     >= 0.5      && < 0.6,
+    errors                    >= 1.3      && < 1.4,
+    filepath                  >= 1.1      && < 1.4,
+    hashable                  >= 1.1      && < 1.2,
+    heist                     >= 0.10     && < 0.11,
+<<<<<<< HEAD
+    HUnit                     >= 1.2     && < 2,
+=======
+    lens                      >= 3.2      && < 3.3,
+>>>>>>> upstream/0.10
+    logict                    >= 0.4.2    && < 0.6,
+    mtl                       >  2.0      && < 2.2,
+    mwc-random                >= 0.8      && < 0.13,
+    pwstore-fast              >= 2.2      && < 2.4,
+    regex-posix               >= 0.95    && < 1,
+    snap-core                 >= 0.9.2    && < 0.10,
+    snap-server               >= 0.9.2    && < 0.10,
+    stm                       >= 2.2      && < 2.5,
+    syb                       >= 0.1      && < 0.4,
+    text                      >= 0.11     && < 0.12,
+    time                      >= 1.1      && < 1.5,
+    transformers              >= 0.2      && < 0.4,
+    unordered-containers      >= 0.1.4    && < 0.3,
+    vector                    >= 0.7.1    && < 0.11,
+    vector-algorithms         >= 0.4      && < 0.6,
+    xmlhtml                   >= 0.1      && < 0.3
+
+  extensions:
+    BangPatterns,
+    CPP,
+    DeriveDataTypeable,
+    ExistentialQuantification,
+    FlexibleContexts,
+    FlexibleInstances,
+    GeneralizedNewtypeDeriving,
+    MultiParamTypeClasses,
+    NoMonomorphismRestriction,
+    OverloadedStrings,
+    PackageImports,
+    Rank2Types,
+    RecordWildCards,
+    ScopedTypeVariables,
+    TemplateHaskell,
+    TypeFamilies,
+    TypeOperators,
+    TypeSynonymInstances
+
+  if impl(ghc >= 6.12.0)
+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+                 -fno-warn-orphans -fno-warn-unused-do-bind
+  else
+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+                 -fno-warn-orphans
+
+Executable snap
+  hs-source-dirs: src
+  main-is: Snap/Starter.hs
+
+  other-modules: Snap.StarterTH
+
+  build-depends:
+    base                >= 4       && < 5,
+    bytestring          >= 0.9.1   && < 0.11,
+    containers          >= 0.3     && < 0.6,
+    directory           >= 1.0     && < 1.3,
+    directory-tree      >= 0.10    && < 0.12,
+    filepath            >= 1.1     && < 1.4,
+    old-time            >= 1.0     && < 1.2,
+    snap-server         >= 0.9.1   && < 0.10,
+    template-haskell    >= 2.2     && < 2.9,
+    text                >= 0.11    && < 0.12
+
+  ghc-prof-options: -prof -auto-all
+
+  if impl(ghc >= 6.12.0)
+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+                 -fno-warn-orphans -fno-warn-unused-do-bind
+  else
+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+                 -fno-warn-orphans
+
+source-repository head
+  type:     git
+  location: https://github.com/snapframework/snap.git

src/Snap/Snaplet/Internal/Types.hs

@@ -284,6 +284,14 @@ instance MonadSnaplet Handler where
     getOpaqueConfig = Handler $ gets _snapletConfig
 
 
+------------------------------------------------------------------------------
+-- | Like 'runBase', but it doesn't require an MVar to be executed.
+runPureBase :: Handler b b a -> Snaplet b -> Snap a
+runPureBase (Handler m) b = do
+        (!a, _) <- L.runLensed m id b
+        return $! a
+
+
 ------------------------------------------------------------------------------
 -- | Gets the route pattern that matched for the handler.  This lets you find
 -- out exactly which of the strings you used in addRoutes matched.

src/Snap/Snaplet/Test.hs

@@ -0,0 +1,107 @@
+-- | The Snap.Snaplet.Test module contains primitives and combinators for
+-- testing Snaplets.
+module Snap.Snaplet.Test
+  (
+    -- ** Testing handlers
+    evalHandler
+  , runHandler
+  , withTemporaryFile
+  )
+  where
+
+
+------------------------------------------------------------------------------
+import           Control.Concurrent.MVar
+import           Control.Exception.Base (finally)
+import qualified Control.Exception as E
+import           Control.Monad.IO.Class
+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 before 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
+
+
+------------------------------------------------------------------------------
+-- | 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 =>
+             RequestBuilder m ()
+           -> Handler b b a
+           -> SnapletInit b b
+           -> m (Either Text Response)
+runHandler rq h s = do
+        app <- getSnaplet s
+        case app of
+          (Left e) -> return $ Left e
+          (Right (a,_)) -> do
+              res <- ST.runHandler rq $ runPureBase h a
+              return $ Right res
+
+
+------------------------------------------------------------------------------
+-- | 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 =>
+              RequestBuilder m ()
+            -> Handler b b a
+            -> SnapletInit b b
+            -> m (Either Text a)
+evalHandler rq h s = do
+    app <- getSnaplet s
+    case app of
+      (Left e) -> return $ Left e
+      (Right (a,_)) -> do
+          res <- ST.evalHandler rq $ runPureBase h a
+          return $ Right res
+
+
+------------------------------------------------------------------------------
+-- | 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.                                                       
+getSnaplet :: MonadIO m =>
+             SnapletInit b b
+           -> m (Either Text (Snaplet b, InitializerState b))
+getSnaplet (SnapletInit initializer) = liftIO $ do
+        mvar <- newEmptyMVar
+        runInitializer mvar "" initializer
+

test/runTestsAndCoverage.sh

@@ -35,6 +35,9 @@ Blackbox.EmbeddedSnaplet
 Blackbox.FooSnaplet
 Blackbox.Tests
 Blackbox.Types
+Snap.Snaplet.Auth.App
+Snap.Snaplet.Auth.Handlers.Tests
+Snap.Snaplet.Auth.Tests
 Snap.Snaplet.Internal.Lensed.Tests
 Snap.Snaplet.Internal.LensT.Tests
 Snap.Snaplet.Internal.RST.Tests