{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, GADTs, TemplateHaskell #-} module Main where ---------------------------------------------------------- -- Section 0: Imports. -- ---------------------------------------------------------- import Control.Applicative import Control.Lens import Data.ByteString (ByteString) import Data.Text (Text) import Data.Maybe (fromMaybe) import qualified Data.Map as M import Snap (Handler, method, Method(..), writeText, writeBS, getParam, SnapletInit, makeSnaplet, addRoutes, route, liftIO, void) import qualified Snap as Snap import Control.Concurrent.Async (async) import Control.Concurrent.MVar (MVar, newEmptyMVar, tryPutMVar, tryTakeMVar, isEmptyMVar) import qualified System.IO.Streams as Stream import qualified System.IO.Streams.Concurrent as Stream import System.Exit (exitSuccess, exitFailure) import Snap.Test.BDD ---------------------------------------------------------- -- Section 1: Example application used for testing. -- ---------------------------------------------------------- data App = App { _mv :: MVar () } makeLenses ''App html :: Text html = "

One

Two

" routes :: [(ByteString, Handler App App ())] routes = [("/test", method GET $ writeText html) ,("/test", method POST $ writeText "") ,("/params", do mq <- getParam "q" writeBS $ fromMaybe "" mq) ,("/redirect", Snap.redirect "/test") ,("/setmv", do m <- use mv liftIO $ tryPutMVar m () return ()) ] app :: MVar () -> SnapletInit App App app mv = makeSnaplet "app" "An snaplet example application." Nothing $ do addRoutes routes return (App mv) ---------------------------------------------------------- -- Section 2: Test suite against application. -- ---------------------------------------------------------- tests :: SnapTesting App () tests = do name "should match selector from a GET request" $ do should $ haveSelector <$> get "/test" <*> css "table td" shouldNot $ haveSelector <$> get "/test" <*> css "table td.doesntexist" shouldNot $ haveSelector <$> get "/redirect" <*> css "table td.doesntexist" shouldNot $ haveSelector <$> get "/invalid_url" <*> css "table td.doesntexist" name "should not match html on POST request" $ shouldNot $ haveText <$> post "/test" M.empty <*> val "" name "should post parameters" $ do should $ haveText <$> post "/params" (params [("q", "hello")]) <*> val "hello" shouldNot $ haveText <$> post "/params" (params [("r", "hello")]) <*> val "hello" name "basic equality" $ do should $ equal <$> val 1 <*> val 1 should $ equal <$> eval (return 1) <*> val 1 name "booleans from other tests" $ do should $ beTrue <$> val True shouldNot $ beTrue <$> val False name "status codes" $ do name "200" $ do should $ succeed <$> get "/test" shouldNot $ succeed <$> get "/invalid_url" name "404" $ do shouldNot $ notfound <$> get "/test" should $ notfound <$> get "/invalid_url" name "3**" $ do should $ redirect <$> get "/redirect" shouldNot $ redirect <$> get "/test" name "3** with target" $ do should $ redirectTo <$> get "/redirect" <*> val "/test" shouldNot $ redirectTo <$> get "/redirect" <*> val "/redirect" shouldNot $ redirectTo <$> get "/test" <*> val "/redirect" name "should reflect stateful changes" $ do let isE = use mv >>= \m -> liftIO $ isEmptyMVar m cleanup (use mv >>= \m -> void $ liftIO $ tryTakeMVar m) $ do should $ equal <$> eval isE <*> val True changes not isE $ post "/setmv" M.empty changes id isE $ post "/setmv" M.empty should $ equal <$> eval isE <*> val True ---------------------------------------------------------- -- Section 3: Code to interface with cabal test. -- ---------------------------------------------------------- main :: IO () main = do (inp, out) <- Stream.makeChanPipe mvar <- newEmptyMVar async $ runSnapTests defaultConfig { reportGenerators = [streamReport out, consoleReport] } (route routes) (app mvar) tests res <- Stream.toList inp if length (filter isFailing res) == 0 then exitSuccess else exitFailure where streamReport out results = do res <- Stream.read results case res of Nothing -> Stream.write Nothing out Just r -> do Stream.write (Just r) out streamReport out results isFailing (TestFail _) = True isFailing (TestError _) = True isFailing _ = False