Permalink
Browse files

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

… 0.10

Conflicts:
	snap.cabal
  • Loading branch information...
2 parents 8d0c2dc + 2391a69 commit 757dea73051178ada9e52f7360fc81ba3b8c1f07 @mightybyte mightybyte committed Nov 24, 2012
View
@@ -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
View
@@ -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,
View
@@ -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
Binary file not shown.
@@ -285,6 +285,14 @@ instance MonadSnaplet Handler where
------------------------------------------------------------------------------
+-- | 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)
View
@@ -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
+
@@ -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
View
Binary file not shown.
Oops, something went wrong.

0 comments on commit 757dea7

Please sign in to comment.