snap-testing (empty) → 0.1.0.0
raw patch · 4 files changed
+465/−0 lines, 4 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, containers, mtl, process, snap, snap-core, text, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- snap-testing.cabal +32/−0
- src/Snap/Testing.hs +401/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Daniel Patterson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Daniel Patterson nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ snap-testing.cabal view
@@ -0,0 +1,32 @@+-- Initial snap-testing.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: snap-testing+version: 0.1.0.0+synopsis: A library for BDD-style testing with the Snap Web Framework+-- description:+homepage: https://github.com/dbp/snap-testing+license: BSD3+license-file: LICENSE+author: Daniel Patterson+maintainer: dbp@dbpmail.net+-- copyright:+category: Web, Snap+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules:+ Snap.Testing+ hs-source-dirs: src+ -- other-modules:+ build-depends: base ==4.6.*,+ QuickCheck == 2.*,+ snap == 0.13.*,+ snap-core == 0.9.*,+ mtl >= 2 && < 3,+ transformers == 0.3.*,+ text == 0.11.*,+ bytestring >= 0.9.1 && < 0.11,+ containers == 0.5.*,+ process == 1.1.*
+ src/Snap/Testing.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}++{-|++This library allows you to write tests against handlers, checking+response codes and bodies, modifications of state, etc. The tests are written+in a hierarchical fashion, with labels to help organize them, and+various ways of reporting on the results of testing are possible.++All of the tests are run in the "test" environment, so be sure to+create the corresponding .cfg files and databases, etc.++Here is a complete example (where routes are your applications routes, and+app is your site initializer):++> runSnapTests [consoleReport, desktopReport] (route routes) app $ do+> name "/auth/new_user" $ do+> name "success" $+> succeeds (get "/auth/new_user")+> name "creates a new account" $+> cleanup clearAccounts $+> changes (+1) countAccounts (post "/auth/new_user" $ params+> [ ("new_user.name", "Jane")+> , ("new_user.email", "jdoe@c.com")+> , ("new_user.password", "foobar")])++There are many different predicates available (and a basic way of+integrating QuickCheck), and it is relatively easy to add+functionality on top of what is built in. For example, to add a way of+creating users and logging in as them for a block of tests you could+do the following (this is using the auth snaplet - if you are doing+somethinge else, obviously the `with auth ...` line would be+different):++> withUser :: SnapTesting App a -> SnapTesting App a+> withUser = modifySite $ \site -> do+> au <- fmap fromJust getRandomUser+> with auth $ forceLogin au+> site++Where `getRandomUser` is a function written in your applications+handler (using whatever state needed).++-}+module Snap.Testing+ (+ -- * Types+ SnapTesting+ , TestRequest+ , TestResult(..)++ -- * Running tests+ , runSnapTests+ , consoleReport+ , linuxDesktopReport++ -- * Labeling+ , name++ -- * Creating Requests+ , get+ , post+ , params++ -- * Request predicates+ , succeeds+ , notfound+ , redirects+ , redirectsto+ , changes+ , changes'+ , contains+ , notcontains++ -- * Stateful unit tests+ , equals++ -- * Run actions after block+ , cleanup++ -- * Evaluate arbitrary action+ , eval++ -- * Create helpers+ , modifySite++ -- * Integrate with QuickCheck+ , quickCheck+ ) where++import Data.Map (Map, fromList)+import Data.ByteString (ByteString, isInfixOf)+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T (append)+import Data.Text.Encoding (encodeUtf8)+import Data.Monoid (mempty)+import Data.Maybe (fromJust)+import Control.Monad (liftM, zipWithM, void)+import Control.Monad.Trans+import Control.Monad.Trans.State (StateT, evalStateT)+import qualified Control.Monad.Trans.State as S (get, put)+import Control.Monad.Trans.Writer (WriterT(..), tell)+import Control.Exception (SomeException, catch)+import System.Process (system)+import Snap.Core (Response(..), getHeader)+import Snap.Snaplet (Handler, SnapletInit)+import Snap.Test (RequestBuilder, getResponseBody)+import qualified Snap.Test as Test+import Snap.Snaplet.Test (runHandler, evalHandler)+import Test.QuickCheck (Args(..), Result(..), Testable, quickCheckWithResult, stdArgs)++-- | The main type for this library, where `b` is your application state,+-- often called `App`. This is a State and Writer monad on top of IO, where the State carries+-- your application (or, more specifically, a top-level handler), and the Writer allows tests+-- to be reported as passing or failing.+type SnapTesting b a = WriterT [TestLog] (StateT (Handler b b (), SnapletInit b b) IO) a++-- | TestRequests are created with `get` and `post`.+type TestRequest = RequestBuilder IO ()++-- | TestResults are what are used to write report generators (two are included). The result+-- is a tree structure.+data TestResult = ResultName Text [TestResult] | ResultPass Text | ResultFail Text+-- TestLog is the flat datastructure that will be turned into the TestResult tree+data TestLog = NameStart Text | NameEnd | TestPass Text | TestFail Text deriving Show++-- | Run a set of tests, putting the results through the specified report generators+runSnapTests :: [[TestResult] -> IO ()] -- ^ Report generators+ -> Handler b b () -- ^ Site that requests are run against (often route routes, where routes are your sites routes).+ -> SnapletInit b b -- ^ Site initializer+ -> SnapTesting b () -- ^ Block of tests+ -> IO ()+runSnapTests rgs site app tests = do+ testlog <- liftM snd $ evalStateT (runWriterT tests) (site, app)+ let res = fst $ buildResult [] testlog+ _ <- zipWithM ($) rgs (repeat res)+ return ()++buildResult :: [TestResult] -> [TestLog] -> ([TestResult], [TestLog])+buildResult acc [] = (acc, [])+buildResult acc ((NameStart nm):xs) =+ let (cur, rest) = buildResult [] xs in+ buildResult (acc ++ [(ResultName nm cur)]) rest+buildResult acc (NameEnd:xs) = (acc, xs)+buildResult acc ((TestPass desc):xs) = buildResult (acc ++ [ResultPass desc]) xs+buildResult acc ((TestFail desc):xs) = buildResult (acc ++ [ResultFail desc]) xs++-- | Prints test results to the console. For example:+--+-- > /auth/new_user+-- > success+-- > PASSED+-- > creates a new account+-- > PASSED+consoleReport :: [TestResult] -> IO ()+consoleReport = cg 0+ where cg _ [] = return ()+ cg indent (ResultName n children : xs) = do+ fmt indent n+ cg (indent + 2) children+ cg indent xs+ cg indent (ResultPass n : xs) = do+ fmt indent (T.append "PASSED " n)+ cg indent xs+ cg indent (ResultFail n : xs) = do+ fmt indent (T.append "FAILED: " n)+ cg indent xs+ fmt indent t = putStrLn $ replicate indent ' ' ++ unpack t++-- | Sends the test results to desktop notifications on linux. Prints how many tests passed and failed.+linuxDesktopReport :: [TestResult] -> IO ()+linuxDesktopReport res = do+ let (passed, total) = count res+ case passed == total of+ True ->+ void $ system $ "notify-send -u low -t 2000 'All Tests Passing' 'All " ++ (show total) ++ " tests passed.'"+ False ->+ void $ system $ "notify-send -u normal -t 2000 'Some Tests Failing' '" ++ (show (total - passed)) ++ " out of " ++ (show total) ++ " tests failed.'"+ where count [] = (0, 0)+ count (ResultName _ children : xs) = count (children ++ xs)+ count (ResultPass _ : xs) = let (p, t) = count xs+ in (1 + p, 1 + t)+ count (ResultFail _ : xs) = let (p, t) = count xs+ in (p, 1 + t)++-- | Labels a block of tests with a descriptive name, to be used in report generation.+name :: Text -- ^ Name of block+ -> SnapTesting b () -- ^ Block of tests+ -> SnapTesting b ()+name s a = do+ tell [NameStart s]+ a+ tell [NameEnd]++-- | Creates a new GET request.+get :: ByteString -- ^ The url to request.+ -> TestRequest+get = flip Test.get mempty++-- | Creates a new POST request, with a set of parameters.+post :: ByteString -- ^ The url to request.+ -> Map ByteString [ByteString] -- ^ The parameters to send.+ -> TestRequest+post = Test.postUrlEncoded++-- | A helper to construct parameters.+params :: [(ByteString, ByteString)] -- ^ Pairs of parameter and value.+ -> Map ByteString [ByteString]+params = fromList . map (\x -> (fst x, [snd x]))++-- | Checks that the handler evaluates to the given value.+equals :: (Show a, Eq a) => a -- ^ Value to compare against+ -> Handler b b a -- ^ Handler that should evaluate to the same thing+ -> SnapTesting b ()+equals a ha = do+ b <- eval ha+ res <- testEqual "Expected value to equal " a b+ tell [res]++-- | Checks that the given request results in a success (200) code.+succeeds :: TestRequest -> SnapTesting b ()+succeeds req = run req testSuccess++-- | Checks that the given request results in a not found (404) code.+notfound :: TestRequest -> SnapTesting b ()+notfound req = run req test404++-- | Checks that the given request results in a redirect (3**) code.+redirects :: TestRequest -> SnapTesting b ()+redirects req = run req testRedirect++-- | Checks that the given request results in a redirect to a specific url.+redirectsto :: TestRequest -- ^ Request to run+ -> Text -- ^ URL it should redirect to+ -> SnapTesting b ()+redirectsto req uri = run req (testRedirectTo $ encodeUtf8 uri)++-- | Checks that the monadic value given changes by the function specified after the request is run.+--+-- For example, if you wanted to make sure that account creation was creating new accounts:+--+-- > changes (+1) countAccounts (post "/auth/new_user" $ params+-- > [ ("new_user.name", "Jane")+-- > , ("new_user.email", "jdoe@c.com")+-- > , ("new_user.password", "foobar")])+changes :: (Show a, Eq a) =>+ (a -> a) -- ^ Change function+ -> Handler b b a -- ^ Monadic value+ -> TestRequest -- ^ Request to run.+ -> SnapTesting b ()+changes delta measure req = do+ (site, app) <- lift S.get+ changes' delta measure (liftIO $ runHandlerSafe req site app)++-- | A more general variant of `changes` that allows an arbitrary block instead of a request.+changes' :: (Show a, Eq a) =>+ (a -> a) -- ^ Change function+ -> Handler b b a -- ^ Monadic value+ -> SnapTesting b c -- ^ Block of tests to run+ -> SnapTesting b ()+changes' delta measure act = do+ before <- eval measure+ _ <- act+ after <- eval measure+ res <- testEqual "Expected value to change" (delta before) after+ tell [res]++-- | Checks that the response body of a given request contains some text.+contains :: TestRequest -- ^ Request to run+ -> Text -- ^ Text that body should contain+ -> SnapTesting b ()+contains req mtch = run req (testBodyContains (encodeUtf8 mtch))++-- | Checks that the response body of a given request does not contain some text.+notcontains :: TestRequest -- ^ Request to run+ -> Text -- ^ Text that body should not contain+ -> SnapTesting b ()+notcontains req mtch = run req (testBodyNotContains (encodeUtf8 mtch))++-- | Runs an action after a block of tests, usually used to remove database state.+cleanup :: Handler b b () -- ^ Action to run after tests+ -> SnapTesting b () -- ^ Tests to run+ -> SnapTesting b ()+cleanup cu act = do+ act+ (_, app) <- lift S.get+ _ <- liftIO $ runHandlerSafe (get "") cu app+ return ()++-- | Evaluate arbitrary actions+eval :: Handler b b a -- ^ Action to evaluate+ -> SnapTesting b a+eval act = do+ (_, app) <- lift S.get+ liftIO $ fmap (either (error. unpack) id) $ evalHandlerSafe act app+++-- | Given a site to site function (like, generating a random user and logging in), run the given block of test with the modified state.+modifySite :: (Handler b b () -> Handler b b ()) -- ^ Site modification function+ -> SnapTesting b a -- ^ Tests to run+ -> SnapTesting b a+modifySite f act = do+ (site, app) <- lift S.get+ lift $ S.put (f site, app)+ res <- act+ lift $ S.put (site, app)+ return res++-- | Allows you to run a quickcheck test. All 100 test passing counts as a pass, any failure a failure.+-- Currently the reporting is really bad (you don't see what the failing example is).+quickCheck :: Testable prop => prop -> SnapTesting b ()+quickCheck p = do+ res <- liftIO $ quickCheckWithResult (stdArgs { chatty = False }) p+ case res of+ Success{} -> tell [TestPass ""]+ GaveUp{} -> tell [TestPass ""]+ Failure{} -> tell [TestFail ""]+ NoExpectedFailure{} -> tell [TestFail ""]++-- Private helpers+runHandlerSafe :: TestRequest -> Handler b b v -> SnapletInit b b -> IO (Either Text Response)+runHandlerSafe req site app =+ catch (runHandler (Just "test") req site app) (\(e::SomeException) -> return $ Left (pack $ show e))++evalHandlerSafe :: Handler b b v -> SnapletInit b b -> IO (Either Text v)+evalHandlerSafe act app =+ catch (evalHandler (Just "test") (get "") act app) (\(e::SomeException) -> return $ Left (pack $ show e))+++run :: TestRequest -> (Response -> SnapTesting b TestLog) -> SnapTesting b ()+run req asrt = do+ (site, app) <- lift S.get+ res <- liftIO $ runHandlerSafe req site app+ case res of+ Left err -> tell [TestFail $ T.append "Handler returned an error: " err]+ Right response -> do+ testlog <- asrt response+ tell [testlog]++-- Low level matchers - these parallel HUnit assertions in Snap.Test++testEqual :: (Eq a, Show a) => Text -> a -> a -> SnapTesting b TestLog+testEqual msg a b = return $ if a == b then TestPass "" else TestFail msg++testBool :: Text -> Bool -> SnapTesting b TestLog+testBool msg b = return $ if b then TestPass "" else TestFail msg++testSuccess :: Response -> SnapTesting b TestLog+testSuccess rsp = testEqual message 200 status+ where+ message = pack $ "Expected success (200) but got (" ++ show status ++ ")"+ status = rspStatus rsp++test404 :: Response -> SnapTesting b TestLog+test404 rsp = testEqual message 404 status+ where+ message = pack $ "Expected Not Found (404) but got (" ++ show status ++ ")"+ status = rspStatus rsp++testRedirectTo :: ByteString+ -> Response+ -> SnapTesting b TestLog+testRedirectTo uri rsp = do+ testRedirect rsp+ testEqual message uri rspUri+ where+ rspUri = fromJust $ getHeader "Location" rsp+ message = pack $ "Expected redirect to " ++ show uri+ ++ " but got redirected to "+ ++ show rspUri ++ " instead"++testRedirect :: Response -> SnapTesting b TestLog+testRedirect rsp = testBool message (300 <= status && status <= 399)+ where+ message = pack $ "Expected redirect but got status code ("+ ++ show status ++ ")"+ status = rspStatus rsp+++containsGen :: (Bool -> Bool) -> Text -> ByteString -> Response -> SnapTesting b TestLog+containsGen b message match rsp =+ do+ body <- liftIO $ getResponseBody rsp+ return $ if b (match `isInfixOf` body) then TestPass "" else TestFail message++testBodyContains :: ByteString+ -> Response+ -> SnapTesting b TestLog+testBodyContains match = containsGen id message match+ where+ message = pack $ "Expected body to contain \"" ++ show match+ ++ "\", but didn't"+++testBodyNotContains :: ByteString+ -> Response+ -> SnapTesting b TestLog+testBodyNotContains match = containsGen not message match+ where+ message = pack $ "Expected body to not contain \"" ++ show match+ ++ "\", but did"