{-# LANGUAGE CPP                                                           #-}
{-# LANGUAGE DataKinds                                                     #-}
{-# LANGUAGE FlexibleContexts                                              #-}
{-# LANGUAGE FlexibleInstances                                             #-}
{-# LANGUAGE GeneralizedNewtypeDeriving                                    #-}
{-# LANGUAGE FunctionalDependencies                                        #-}
{-# LANGUAGE MultiParamTypeClasses                                         #-}
{-# LANGUAGE OverloadedStrings                                             #-}
{-# LANGUAGE ScopedTypeVariables                                           #-}
{-# LANGUAGE TupleSections                                                 #-}
{-# LANGUAGE TypeFamilies                                                  #-}
{-# LANGUAGE TypeSynonymInstances                                          #-}

module Test.Hspec.Snap (
  -- * Running blocks of hspec-snap tests
    snap
  , modifySite
  , modifySite'
  , afterEval
  , beforeEval

  -- * Core data types
  , TestResponse(..)
  , RespCode(..)
  , SnapHspecM

  -- * Factory style test data generation
  , Factory(..)

  -- * Requests
  , delete
  , get
  , get'
  , post
  , postJson
  , put
  , put'
  , params

  -- * Helpers for dealing with TestResponses
  , restrictResponse

  -- * Dealing with session state (EXPERIMENTAL)
  , recordSession
  , HasSession(..)
  , sessionShouldContain
  , sessionShouldNotContain

  -- * Evaluating application code
  , eval

  -- * Unit test assertions
  , shouldChange
  , shouldEqual
  , shouldNotEqual
  , shouldBeTrue
  , shouldNotBeTrue

  -- * Response assertions
  , should200
  , shouldNot200
  , should404
  , shouldNot404
  , should300
  , shouldNot300
  , should300To
  , shouldNot300To
  , shouldHaveSelector
  , shouldNotHaveSelector
  , shouldHaveText
  , shouldNotHaveText

  -- * Form tests
  , FormExpectations(..)
  , form


  -- * Internal types and helpers
  , SnapHspecState(..)
  , setResult
  , runRequest
  , runHandlerSafe
  , evalHandlerSafe
  ) where

import           Control.Applicative     ((<$>))
import           Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar,
                                          readMVar, takeMVar)

import           Control.Exception       (SomeException, catch)
import           Control.Monad           (void)
import           Control.Monad.State     (StateT (..), runStateT)
import qualified Control.Monad.State     as S (get, put)
import           Control.Monad.Trans     (liftIO)
import           Data.Aeson              (ToJSON, encode)
import           Data.ByteString         (ByteString)
import           Data.ByteString.Lazy    (fromStrict, toStrict)
import qualified Data.ByteString.Lazy    as LBS (ByteString)
import qualified Data.Map                as M
import           Data.Maybe              (fromMaybe)
import           Data.Text               (Text)
import qualified Data.Text               as T
import qualified Data.Text.Encoding      as T
import           Snap.Core               (Response (..), getHeader)
import qualified Snap.Core               as Snap
import           Snap.Snaplet            (Handler, Snaplet, SnapletInit,
                                          SnapletLens, with)
import           Snap.Snaplet.Session    (SessionManager, commitSession,
                                          sessionToList, setInSession)
import           Snap.Snaplet.Test       (InitializerState, closeSnaplet,
                                          evalHandler', getSnaplet, runHandler')
import           Snap.Test               (RequestBuilder, getResponseBody)
import qualified Snap.Test               as Test
import           Test.Hspec
import           Test.Hspec.Core.Spec
import qualified Text.Digestive          as DF
import qualified Text.HandsomeSoup       as HS
import qualified Text.XML.HXT.Core       as HXT

-- derives Num and Ord to avoid excessive newtype wrapping and unwrapping
-- in pattern matching, etc.
newtype RespCode = RespCode Int deriving (Int -> RespCode -> ShowS
[RespCode] -> ShowS
RespCode -> String
(Int -> RespCode -> ShowS)
-> (RespCode -> String) -> ([RespCode] -> ShowS) -> Show RespCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RespCode] -> ShowS
$cshowList :: [RespCode] -> ShowS
show :: RespCode -> String
$cshow :: RespCode -> String
showsPrec :: Int -> RespCode -> ShowS
$cshowsPrec :: Int -> RespCode -> ShowS
Show, ReadPrec [RespCode]
ReadPrec RespCode
Int -> ReadS RespCode
ReadS [RespCode]
(Int -> ReadS RespCode)
-> ReadS [RespCode]
-> ReadPrec RespCode
-> ReadPrec [RespCode]
-> Read RespCode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RespCode]
$creadListPrec :: ReadPrec [RespCode]
readPrec :: ReadPrec RespCode
$creadPrec :: ReadPrec RespCode
readList :: ReadS [RespCode]
$creadList :: ReadS [RespCode]
readsPrec :: Int -> ReadS RespCode
$creadsPrec :: Int -> ReadS RespCode
Read, RespCode -> RespCode -> Bool
(RespCode -> RespCode -> Bool)
-> (RespCode -> RespCode -> Bool) -> Eq RespCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RespCode -> RespCode -> Bool
$c/= :: RespCode -> RespCode -> Bool
== :: RespCode -> RespCode -> Bool
$c== :: RespCode -> RespCode -> Bool
Eq, Integer -> RespCode
RespCode -> RespCode
RespCode -> RespCode -> RespCode
(RespCode -> RespCode -> RespCode)
-> (RespCode -> RespCode -> RespCode)
-> (RespCode -> RespCode -> RespCode)
-> (RespCode -> RespCode)
-> (RespCode -> RespCode)
-> (RespCode -> RespCode)
-> (Integer -> RespCode)
-> Num RespCode
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> RespCode
$cfromInteger :: Integer -> RespCode
signum :: RespCode -> RespCode
$csignum :: RespCode -> RespCode
abs :: RespCode -> RespCode
$cabs :: RespCode -> RespCode
negate :: RespCode -> RespCode
$cnegate :: RespCode -> RespCode
* :: RespCode -> RespCode -> RespCode
$c* :: RespCode -> RespCode -> RespCode
- :: RespCode -> RespCode -> RespCode
$c- :: RespCode -> RespCode -> RespCode
+ :: RespCode -> RespCode -> RespCode
$c+ :: RespCode -> RespCode -> RespCode
Num, Eq RespCode
Eq RespCode
-> (RespCode -> RespCode -> Ordering)
-> (RespCode -> RespCode -> Bool)
-> (RespCode -> RespCode -> Bool)
-> (RespCode -> RespCode -> Bool)
-> (RespCode -> RespCode -> Bool)
-> (RespCode -> RespCode -> RespCode)
-> (RespCode -> RespCode -> RespCode)
-> Ord RespCode
RespCode -> RespCode -> Bool
RespCode -> RespCode -> Ordering
RespCode -> RespCode -> RespCode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RespCode -> RespCode -> RespCode
$cmin :: RespCode -> RespCode -> RespCode
max :: RespCode -> RespCode -> RespCode
$cmax :: RespCode -> RespCode -> RespCode
>= :: RespCode -> RespCode -> Bool
$c>= :: RespCode -> RespCode -> Bool
> :: RespCode -> RespCode -> Bool
$c> :: RespCode -> RespCode -> Bool
<= :: RespCode -> RespCode -> Bool
$c<= :: RespCode -> RespCode -> Bool
< :: RespCode -> RespCode -> Bool
$c< :: RespCode -> RespCode -> Bool
compare :: RespCode -> RespCode -> Ordering
$ccompare :: RespCode -> RespCode -> Ordering
$cp1Ord :: Eq RespCode
Ord)

-- | The result of making requests against your application. Most
-- assertions act against these types (for example, `should200`,
-- `shouldHaveSelector`, etc).
data TestResponse = Html RespCode Text
                  | Json RespCode LBS.ByteString
                  | NotFound
                  | Redirect RespCode Text
                  | Other RespCode
                  | Empty
                  deriving (Int -> TestResponse -> ShowS
[TestResponse] -> ShowS
TestResponse -> String
(Int -> TestResponse -> ShowS)
-> (TestResponse -> String)
-> ([TestResponse] -> ShowS)
-> Show TestResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestResponse] -> ShowS
$cshowList :: [TestResponse] -> ShowS
show :: TestResponse -> String
$cshow :: TestResponse -> String
showsPrec :: Int -> TestResponse -> ShowS
$cshowsPrec :: Int -> TestResponse -> ShowS
Show, TestResponse -> TestResponse -> Bool
(TestResponse -> TestResponse -> Bool)
-> (TestResponse -> TestResponse -> Bool) -> Eq TestResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestResponse -> TestResponse -> Bool
$c/= :: TestResponse -> TestResponse -> Bool
== :: TestResponse -> TestResponse -> Bool
$c== :: TestResponse -> TestResponse -> Bool
Eq)

-- | The main monad that tests run inside of. This allows both access
-- to the application (via requests and `eval`) and to running
-- assertions (like `should404` or `shouldHaveText`).
type SnapHspecM b = StateT (SnapHspecState b) IO

-- | Internal state used to share site initialization across tests, and to propogate failures.
-- Understanding it is completely unnecessary to use the library.
--
-- The fields it contains, in order, are:
--
-- > Result
-- > Main handler
-- > Startup state
-- > Startup state
-- > Session state
-- > Before handler (runs before each eval)
-- > After handler (runs after each eval).
data SnapHspecState b = SnapHspecState
#if MIN_VERSION_hspec(2,5,0)
                                       ResultStatus
#else
                                       Result
#endif
                                       (Handler b b ())
                                       (Snaplet b)
                                       (InitializerState b)
                                       (MVar [(Text, Text)])
                                       (Handler b b ())
                                       (Handler b b ())


instance Example (SnapHspecM b ()) where
  type Arg (SnapHspecM b ()) = SnapHspecState b
  evaluateExample :: SnapHspecM b ()
-> Params
-> (ActionWith (Arg (SnapHspecM b ())) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample SnapHspecM b ()
s Params
_ ActionWith (Arg (SnapHspecM b ())) -> IO ()
cb ProgressCallback
_ =
    do MVar ResultStatus
mv <- IO (MVar ResultStatus)
forall a. IO (MVar a)
newEmptyMVar
       ActionWith (Arg (SnapHspecM b ())) -> IO ()
cb (ActionWith (Arg (SnapHspecM b ())) -> IO ())
-> ActionWith (Arg (SnapHspecM b ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Arg (SnapHspecM b ())
st -> do ((),SnapHspecState ResultStatus
r' Handler b b ()
_ Snaplet b
_ InitializerState b
_ MVar [(Text, Text)]
_ Handler b b ()
_ Handler b b ()
_) <- SnapHspecM b () -> SnapHspecState b -> IO ((), SnapHspecState b)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT SnapHspecM b ()
s Arg (SnapHspecM b ())
SnapHspecState b
st
                      MVar ResultStatus -> ResultStatus -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ResultStatus
mv ResultStatus
r'
#if MIN_VERSION_hspec(2,5,0)
       ResultStatus
rs <- MVar ResultStatus -> IO ResultStatus
forall a. MVar a -> IO a
takeMVar MVar ResultStatus
mv
       Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> ResultStatus -> Result
Result String
"" ResultStatus
rs
#else
       takeMVar mv
#endif

-- | Factory instances allow you to easily generate test data.
--
-- Essentially, you specify a default way of constructing a
-- data type, and allow certain parts of it to be modified (via
-- the 'fields' data structure).
--
-- An example follows:
--
-- > data Foo = Foo Int
-- > newtype FooFields = FooFields (IO Int)
-- > instance Factory App Foo FooFields where
-- >   fields = FooFields randomIO
-- >   save f = liftIO f >>= saveFoo . Foo1
-- >
-- > main = do create id :: SnapHspecM App Foo
-- >           create (const $ FooFields (return 1)) :: SnapHspecM App Foo
class Factory b a d | a -> b, a -> d, d -> a where
  fields :: d
  save :: d -> SnapHspecM b a
  create :: (d -> d) -> SnapHspecM b a
  create d -> d
transform = d -> SnapHspecM b a
forall b a d. Factory b a d => d -> SnapHspecM b a
save (d -> SnapHspecM b a) -> d -> SnapHspecM b a
forall a b. (a -> b) -> a -> b
$ d -> d
transform d
forall b a d. Factory b a d => d
fields
  reload :: a -> SnapHspecM b a
  reload = a -> SnapHspecM b a
forall (m :: * -> *) a. Monad m => a -> m a
return


-- | The way to run a block of `SnapHspecM` tests within an `hspec`
-- test suite. This takes both the top level handler (usually `route
-- routes`, where `routes` are all the routes for your site) and the
-- site initializer (often named `app`), and a block of tests. A test
-- suite can have multiple calls to `snap`, though each one will cause
-- the site initializer to run, which is often a slow operation (and
-- will slow down test suites).
snap :: Handler b b () -> SnapletInit b b -> SpecWith (SnapHspecState b) -> Spec
snap :: Handler b b ()
-> SnapletInit b b -> SpecWith (SnapHspecState b) -> Spec
snap Handler b b ()
site SnapletInit b b
app SpecWith (SnapHspecState b)
spec = do
  Either Text (Snaplet b, InitializerState b)
snapinit <- IO (Either Text (Snaplet b, InitializerState b))
-> SpecM () (Either Text (Snaplet b, InitializerState b))
forall r a. IO r -> SpecM a r
runIO (IO (Either Text (Snaplet b, InitializerState b))
 -> SpecM () (Either Text (Snaplet b, InitializerState b)))
-> IO (Either Text (Snaplet b, InitializerState b))
-> SpecM () (Either Text (Snaplet b, InitializerState b))
forall a b. (a -> b) -> a -> b
$ Maybe String
-> SnapletInit b b
-> IO (Either Text (Snaplet b, InitializerState b))
forall (m :: * -> *) b.
MonadIO m =>
Maybe String
-> SnapletInit b b
-> m (Either Text (Snaplet b, InitializerState b))
getSnaplet (String -> Maybe String
forall a. a -> Maybe a
Just String
"test") SnapletInit b b
app
  MVar [(Text, Text)]
mv <- IO (MVar [(Text, Text)]) -> SpecM () (MVar [(Text, Text)])
forall r a. IO r -> SpecM a r
runIO ([(Text, Text)] -> IO (MVar [(Text, Text)])
forall a. a -> IO (MVar a)
newMVar [])
  case Either Text (Snaplet b, InitializerState b)
snapinit of
    Left Text
err -> String -> Spec
forall a. HasCallStack => String -> a
error (String -> Spec) -> String -> Spec
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
err
    Right (Snaplet b
snaplet, InitializerState b
initstate) ->
      ActionWith () -> Spec -> Spec
forall a. ActionWith a -> SpecWith a -> SpecWith a
afterAll (IO () -> ActionWith ()
forall a b. a -> b -> a
const (IO () -> ActionWith ()) -> IO () -> ActionWith ()
forall a b. (a -> b) -> a -> b
$ InitializerState b -> IO ()
forall (m :: * -> *) b. MonadIO m => InitializerState b -> m ()
closeSnaplet InitializerState b
initstate) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
        IO (SnapHspecState b) -> SpecWith (SnapHspecState b) -> Spec
forall a. IO a -> SpecWith a -> Spec
before (SnapHspecState b -> IO (SnapHspecState b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
forall b.
ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
SnapHspecState ResultStatus
Success Handler b b ()
site Snaplet b
snaplet InitializerState b
initstate MVar [(Text, Text)]
mv (() -> Handler b b ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (() -> Handler b b ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))) SpecWith (SnapHspecState b)
spec

-- | This allows you to change the default handler you are running
-- requests against within a block. This is most likely useful for
-- setting request state (for example, logging a user in).
modifySite :: (Handler b b () -> Handler b b ())
           -> SpecWith (SnapHspecState b)
           -> SpecWith (SnapHspecState b)
modifySite :: (Handler b b () -> Handler b b ())
-> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b)
modifySite Handler b b () -> Handler b b ()
f = (SnapHspecState b -> IO (SnapHspecState b))
-> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b)
forall b a. (b -> IO a) -> SpecWith a -> SpecWith b
beforeWith (\(SnapHspecState ResultStatus
r Handler b b ()
site Snaplet b
snaplet InitializerState b
initst MVar [(Text, Text)]
sess Handler b b ()
bef Handler b b ()
aft) ->
                             SnapHspecState b -> IO (SnapHspecState b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
forall b.
ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
SnapHspecState ResultStatus
r (Handler b b () -> Handler b b ()
f Handler b b ()
site) Snaplet b
snaplet InitializerState b
initst MVar [(Text, Text)]
sess Handler b b ()
bef Handler b b ()
aft))

-- | This performs a similar operation to `modifySite` but in the context
-- of `SnapHspecM` (which is needed if you need to `eval`, produce values, and
-- hand them somewhere else (so they can't be created within `f`).
modifySite' :: (Handler b b () -> Handler b b ())
            -> SnapHspecM b a
            -> SnapHspecM b a
modifySite' :: (Handler b b () -> Handler b b ())
-> SnapHspecM b a -> SnapHspecM b a
modifySite' Handler b b () -> Handler b b ()
f SnapHspecM b a
a = do (SnapHspecState ResultStatus
r Handler b b ()
site Snaplet b
s InitializerState b
i MVar [(Text, Text)]
sess Handler b b ()
bef Handler b b ()
aft) <- StateT (SnapHspecState b) IO (SnapHspecState b)
forall s (m :: * -> *). MonadState s m => m s
S.get
                     SnapHspecState b -> StateT (SnapHspecState b) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
forall b.
ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
SnapHspecState ResultStatus
r (Handler b b () -> Handler b b ()
f Handler b b ()
site) Snaplet b
s InitializerState b
i MVar [(Text, Text)]
sess Handler b b ()
bef Handler b b ()
aft)
                     SnapHspecM b a
a

-- | Evaluate a Handler action after each test.
afterEval :: Handler b b () -> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b)
afterEval :: Handler b b ()
-> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b)
afterEval Handler b b ()
h = ActionWith (SnapHspecState b)
-> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b)
forall a. ActionWith a -> SpecWith a -> SpecWith a
after (\(SnapHspecState ResultStatus
_r Handler b b ()
_site Snaplet b
s InitializerState b
i MVar [(Text, Text)]
_ Handler b b ()
_ Handler b b ()
_) ->
                       do Either Text ()
res <- Handler b b ()
-> Snaplet b -> InitializerState b -> IO (Either Text ())
forall b v.
Handler b b v
-> Snaplet b -> InitializerState b -> IO (Either Text v)
evalHandlerSafe Handler b b ()
h Snaplet b
s InitializerState b
i
                          case Either Text ()
res of
                            Right ()
_ -> ActionWith ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                            Left Text
msg -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print Text
msg)

-- | Evaluate a Handler action before each test.
beforeEval :: Handler b b () -> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b)
beforeEval :: Handler b b ()
-> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b)
beforeEval Handler b b ()
h = (SnapHspecState b -> IO (SnapHspecState b))
-> SpecWith (SnapHspecState b) -> SpecWith (SnapHspecState b)
forall b a. (b -> IO a) -> SpecWith a -> SpecWith b
beforeWith (\state :: SnapHspecState b
state@(SnapHspecState ResultStatus
_r Handler b b ()
_site Snaplet b
s InitializerState b
i MVar [(Text, Text)]
_ Handler b b ()
_ Handler b b ()
_) -> do IO (Either Text ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Text ()) -> IO ()) -> IO (Either Text ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Handler b b ()
-> Snaplet b -> InitializerState b -> IO (Either Text ())
forall b v.
Handler b b v
-> Snaplet b -> InitializerState b -> IO (Either Text v)
evalHandlerSafe Handler b b ()
h Snaplet b
s InitializerState b
i
                                                                            SnapHspecState b -> IO (SnapHspecState b)
forall (m :: * -> *) a. Monad m => a -> m a
return SnapHspecState b
state)

class HasSession b where
  getSessionLens :: SnapletLens b SessionManager

recordSession :: HasSession b => SnapHspecM b a -> SnapHspecM b a
recordSession :: SnapHspecM b a -> SnapHspecM b a
recordSession SnapHspecM b a
a =
  do (SnapHspecState ResultStatus
r Handler b b ()
site Snaplet b
s InitializerState b
i MVar [(Text, Text)]
mv Handler b b ()
bef Handler b b ()
aft) <- StateT (SnapHspecState b) IO (SnapHspecState b)
forall s (m :: * -> *). MonadState s m => m s
S.get
     SnapHspecState b -> StateT (SnapHspecState b) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
forall b.
ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
SnapHspecState ResultStatus
r Handler b b ()
site Snaplet b
s InitializerState b
i MVar [(Text, Text)]
mv
                             (do [(Text, Text)]
ps <- IO [(Text, Text)] -> Handler b b [(Text, Text)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Text)] -> Handler b b [(Text, Text)])
-> IO [(Text, Text)] -> Handler b b [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ MVar [(Text, Text)] -> IO [(Text, Text)]
forall a. MVar a -> IO a
readMVar MVar [(Text, Text)]
mv
                                 SnapletLens b SessionManager
-> Handler b SessionManager () -> Handler b b ()
forall (m :: * -> * -> * -> *) v v' b a.
MonadSnaplet m =>
SnapletLens v v' -> m b v' a -> m b v a
with SnapletLens b SessionManager
forall b. HasSession b => SnapletLens b SessionManager
getSessionLens (Handler b SessionManager () -> Handler b b ())
-> Handler b SessionManager () -> Handler b b ()
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Handler b SessionManager ())
-> [(Text, Text)] -> Handler b SessionManager ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Text -> Text -> Handler b SessionManager ())
-> (Text, Text) -> Handler b SessionManager ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Handler b SessionManager ()
forall b. Text -> Text -> Handler b SessionManager ()
setInSession) [(Text, Text)]
ps
                                 SnapletLens b SessionManager
-> Handler b SessionManager () -> Handler b b ()
forall (m :: * -> * -> * -> *) v v' b a.
MonadSnaplet m =>
SnapletLens v v' -> m b v' a -> m b v a
with SnapletLens b SessionManager
forall b. HasSession b => SnapletLens b SessionManager
getSessionLens Handler b SessionManager ()
forall b. Handler b SessionManager ()
commitSession)
                             (do [(Text, Text)]
ps' <- SnapletLens b SessionManager
-> Handler b SessionManager [(Text, Text)]
-> Handler b b [(Text, Text)]
forall (m :: * -> * -> * -> *) v v' b a.
MonadSnaplet m =>
SnapletLens v v' -> m b v' a -> m b v a
with SnapletLens b SessionManager
forall b. HasSession b => SnapletLens b SessionManager
getSessionLens Handler b SessionManager [(Text, Text)]
forall b. Handler b SessionManager [(Text, Text)]
sessionToList
                                 Handler b b [(Text, Text)] -> Handler b b ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Handler b b [(Text, Text)] -> Handler b b ())
-> (IO [(Text, Text)] -> Handler b b [(Text, Text)])
-> IO [(Text, Text)]
-> Handler b b ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [(Text, Text)] -> Handler b b [(Text, Text)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Text)] -> Handler b b ())
-> IO [(Text, Text)] -> Handler b b ()
forall a b. (a -> b) -> a -> b
$ MVar [(Text, Text)] -> IO [(Text, Text)]
forall a. MVar a -> IO a
takeMVar MVar [(Text, Text)]
mv
                                 IO () -> Handler b b ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler b b ()) -> IO () -> Handler b b ()
forall a b. (a -> b) -> a -> b
$ MVar [(Text, Text)] -> [(Text, Text)] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [(Text, Text)]
mv [(Text, Text)]
ps'))
     a
res <- SnapHspecM b a
a
     (SnapHspecState ResultStatus
r' Handler b b ()
_ Snaplet b
_ InitializerState b
_ MVar [(Text, Text)]
_ Handler b b ()
_ Handler b b ()
_) <- StateT (SnapHspecState b) IO (SnapHspecState b)
forall s (m :: * -> *). MonadState s m => m s
S.get
     StateT (SnapHspecState b) IO [(Text, Text)]
-> StateT (SnapHspecState b) IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT (SnapHspecState b) IO [(Text, Text)]
 -> StateT (SnapHspecState b) IO ())
-> (IO [(Text, Text)]
    -> StateT (SnapHspecState b) IO [(Text, Text)])
-> IO [(Text, Text)]
-> StateT (SnapHspecState b) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [(Text, Text)] -> StateT (SnapHspecState b) IO [(Text, Text)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Text)] -> StateT (SnapHspecState b) IO ())
-> IO [(Text, Text)] -> StateT (SnapHspecState b) IO ()
forall a b. (a -> b) -> a -> b
$ MVar [(Text, Text)] -> IO [(Text, Text)]
forall a. MVar a -> IO a
takeMVar MVar [(Text, Text)]
mv
     IO () -> StateT (SnapHspecState b) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (SnapHspecState b) IO ())
-> IO () -> StateT (SnapHspecState b) IO ()
forall a b. (a -> b) -> a -> b
$ MVar [(Text, Text)] -> [(Text, Text)] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [(Text, Text)]
mv []
     SnapHspecState b -> StateT (SnapHspecState b) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
forall b.
ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
SnapHspecState ResultStatus
r' Handler b b ()
site Snaplet b
s InitializerState b
i MVar [(Text, Text)]
mv Handler b b ()
bef Handler b b ()
aft)
     a -> SnapHspecM b a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

sessContents :: SnapHspecM b Text
sessContents :: SnapHspecM b Text
sessContents = do
  (SnapHspecState ResultStatus
_ Handler b b ()
_ Snaplet b
_ InitializerState b
_ MVar [(Text, Text)]
mv Handler b b ()
_ Handler b b ()
_) <- StateT (SnapHspecState b) IO (SnapHspecState b)
forall s (m :: * -> *). MonadState s m => m s
S.get
  [(Text, Text)]
ps <- IO [(Text, Text)] -> StateT (SnapHspecState b) IO [(Text, Text)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Text)] -> StateT (SnapHspecState b) IO [(Text, Text)])
-> IO [(Text, Text)] -> StateT (SnapHspecState b) IO [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ MVar [(Text, Text)] -> IO [(Text, Text)]
forall a. MVar a -> IO a
readMVar MVar [(Text, Text)]
mv
  Text -> SnapHspecM b Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> SnapHspecM b Text) -> Text -> SnapHspecM b Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text -> Text) -> (Text, Text) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Text
T.append) [(Text, Text)]
ps)

sessionShouldContain :: Text -> SnapHspecM b ()
sessionShouldContain :: Text -> SnapHspecM b ()
sessionShouldContain Text
t =
  do Text
contents <- SnapHspecM b Text
forall b. SnapHspecM b Text
sessContents
     if Text
t Text -> Text -> Bool
`T.isInfixOf` Text
contents
       then ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
       else ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ String
"Session did not contain: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\nSession was:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
contents)

sessionShouldNotContain :: Text -> SnapHspecM b ()
sessionShouldNotContain :: Text -> SnapHspecM b ()
sessionShouldNotContain Text
t =
  do Text
contents <- SnapHspecM b Text
forall b. SnapHspecM b Text
sessContents
     if Text
t Text -> Text -> Bool
`T.isInfixOf` Text
contents
       then ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ String
"Session should not have contained: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\nSession was:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
contents)
       else ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success

-- | Runs a DELETE request
delete :: Text -> SnapHspecM b TestResponse
delete :: Text -> SnapHspecM b TestResponse
delete Text
path = RequestBuilder IO () -> SnapHspecM b TestResponse
forall b. RequestBuilder IO () -> SnapHspecM b TestResponse
runRequest (ByteString -> Params -> RequestBuilder IO ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Params -> RequestBuilder m ()
Test.delete (Text -> ByteString
T.encodeUtf8 Text
path) Params
forall k a. Map k a
M.empty)

-- | Runs a GET request.
get :: Text -> SnapHspecM b TestResponse
get :: Text -> SnapHspecM b TestResponse
get Text
path = Text -> Params -> SnapHspecM b TestResponse
forall b. Text -> Params -> SnapHspecM b TestResponse
get' Text
path Params
forall k a. Map k a
M.empty

-- | Runs a GET request, with a set of parameters.
get' :: Text -> Snap.Params -> SnapHspecM b TestResponse
get' :: Text -> Params -> SnapHspecM b TestResponse
get' Text
path Params
ps = RequestBuilder IO () -> SnapHspecM b TestResponse
forall b. RequestBuilder IO () -> SnapHspecM b TestResponse
runRequest (ByteString -> Params -> RequestBuilder IO ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Params -> RequestBuilder m ()
Test.get (Text -> ByteString
T.encodeUtf8 Text
path) Params
ps)

-- | A helper to construct parameters.
params :: [(ByteString, ByteString)] -- ^ Pairs of parameter and value.
       -> Snap.Params
params :: [(ByteString, ByteString)] -> Params
params = [(ByteString, [ByteString])] -> Params
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ByteString, [ByteString])] -> Params)
-> ([(ByteString, ByteString)] -> [(ByteString, [ByteString])])
-> [(ByteString, ByteString)]
-> Params
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> (ByteString, [ByteString]))
-> [(ByteString, ByteString)] -> [(ByteString, [ByteString])]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString, ByteString)
x -> ((ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst (ByteString, ByteString)
x, [(ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (ByteString, ByteString)
x]))

-- | Creates a new POST request, with a set of parameters.
post :: Text -> Snap.Params -> SnapHspecM b TestResponse
post :: Text -> Params -> SnapHspecM b TestResponse
post Text
path Params
ps = RequestBuilder IO () -> SnapHspecM b TestResponse
forall b. RequestBuilder IO () -> SnapHspecM b TestResponse
runRequest (ByteString -> Params -> RequestBuilder IO ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Params -> RequestBuilder m ()
Test.postUrlEncoded (Text -> ByteString
T.encodeUtf8 Text
path) Params
ps)

-- | Creates a new POST request with a given JSON value as the request body.
postJson :: ToJSON tj => Text -> tj -> SnapHspecM b TestResponse
postJson :: Text -> tj -> SnapHspecM b TestResponse
postJson Text
path tj
json = RequestBuilder IO () -> SnapHspecM b TestResponse
forall b. RequestBuilder IO () -> SnapHspecM b TestResponse
runRequest (RequestBuilder IO () -> SnapHspecM b TestResponse)
-> RequestBuilder IO () -> SnapHspecM b TestResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString -> RequestBuilder IO ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> ByteString -> ByteString -> RequestBuilder m ()
Test.postRaw (Text -> ByteString
T.encodeUtf8 Text
path)
                                               ByteString
"application/json"
                                               (ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ tj -> ByteString
forall a. ToJSON a => a -> ByteString
encode tj
json)

-- | Creates a new PUT request, with a set of parameters, with a default type of "application/x-www-form-urlencoded"
put :: Text -> Snap.Params -> SnapHspecM b TestResponse
put :: Text -> Params -> SnapHspecM b TestResponse
put Text
path Params
params' = Text -> Text -> Params -> SnapHspecM b TestResponse
forall b. Text -> Text -> Params -> SnapHspecM b TestResponse
put' Text
path Text
"application/x-www-form-urlencoded" Params
params'

-- | Creates a new PUT request with a configurable MIME/type
put' :: Text -> Text -> Snap.Params -> SnapHspecM b TestResponse
put' :: Text -> Text -> Params -> SnapHspecM b TestResponse
put' Text
path Text
mime Params
params' = RequestBuilder IO () -> SnapHspecM b TestResponse
forall b. RequestBuilder IO () -> SnapHspecM b TestResponse
runRequest (RequestBuilder IO () -> SnapHspecM b TestResponse)
-> RequestBuilder IO () -> SnapHspecM b TestResponse
forall a b. (a -> b) -> a -> b
$ do
  ByteString -> ByteString -> ByteString -> RequestBuilder IO ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> ByteString -> ByteString -> RequestBuilder m ()
Test.put (Text -> ByteString
T.encodeUtf8 Text
path) (Text -> ByteString
T.encodeUtf8 Text
mime) ByteString
""
  Params -> RequestBuilder IO ()
forall (m :: * -> *). Monad m => Params -> RequestBuilder m ()
Test.setQueryString Params
params'

-- | Restricts a response to matches for a given CSS selector.
-- Does nothing to non-Html responses.
restrictResponse :: Text -> TestResponse -> TestResponse
restrictResponse :: Text -> TestResponse -> TestResponse
restrictResponse Text
selector (Html RespCode
code Text
body) =
  case LA String String -> String -> [String]
forall a b. LA a b -> a -> [b]
HXT.runLA (LA String XmlTree -> LA String String
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
HXT.xshow (LA String XmlTree -> LA String String)
-> LA String XmlTree -> LA String String
forall a b. (a -> b) -> a -> b
$ LA String XmlTree
forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
HXT.hread LA String XmlTree -> LA XmlTree XmlTree -> LA String XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
HXT.>>> String -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
HS.css (Text -> String
T.unpack Text
selector)) (Text -> String
T.unpack Text
body) of
    [] -> RespCode -> Text -> TestResponse
Html RespCode
code Text
""
    [String]
matches -> RespCode -> Text -> TestResponse
Html RespCode
code ([Text] -> Text
T.concat ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack [String]
matches))
restrictResponse Text
_ TestResponse
r = TestResponse
r

-- | Runs an arbitrary stateful action from your application.
eval :: Handler b b a -> SnapHspecM b a
eval :: Handler b b a -> SnapHspecM b a
eval Handler b b a
act = do (SnapHspecState ResultStatus
_ Handler b b ()
_site Snaplet b
app InitializerState b
is MVar [(Text, Text)]
_mv Handler b b ()
bef Handler b b ()
aft) <- StateT (SnapHspecState b) IO (SnapHspecState b)
forall s (m :: * -> *). MonadState s m => m s
S.get
              IO a -> SnapHspecM b a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> SnapHspecM b a) -> IO a -> SnapHspecM b a
forall a b. (a -> b) -> a -> b
$ (Text -> a) -> (a -> a) -> Either Text a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (Text -> String) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) a -> a
forall a. a -> a
id (Either Text a -> a) -> IO (Either Text a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler b b a
-> Snaplet b -> InitializerState b -> IO (Either Text a)
forall b v.
Handler b b v
-> Snaplet b -> InitializerState b -> IO (Either Text v)
evalHandlerSafe (do Handler b b ()
bef
                                                                            a
r <- Handler b b a
act
                                                                            Handler b b ()
aft
                                                                            a -> Handler b b a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r) Snaplet b
app InitializerState b
is


-- | Records a test Success or Fail. Only the first Fail will be
-- recorded (and will cause the whole block to Fail).
#if MIN_VERSION_hspec(2,5,0)
setResult :: ResultStatus -> SnapHspecM b ()
#else
setResult :: Result -> SnapHspecM b ()
#endif
setResult :: ResultStatus -> SnapHspecM b ()
setResult ResultStatus
r = do (SnapHspecState ResultStatus
r' Handler b b ()
s Snaplet b
a InitializerState b
i MVar [(Text, Text)]
sess Handler b b ()
bef Handler b b ()
aft) <- StateT (SnapHspecState b) IO (SnapHspecState b)
forall s (m :: * -> *). MonadState s m => m s
S.get
                 case ResultStatus
r' of
                   ResultStatus
Success -> SnapHspecState b -> SnapHspecM b ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
forall b.
ResultStatus
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> MVar [(Text, Text)]
-> Handler b b ()
-> Handler b b ()
-> SnapHspecState b
SnapHspecState ResultStatus
r Handler b b ()
s Snaplet b
a InitializerState b
i MVar [(Text, Text)]
sess Handler b b ()
bef Handler b b ()
aft)
                   ResultStatus
_ -> () -> SnapHspecM b ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Asserts that a given stateful action will produce a specific different result after
-- an action has been run.
shouldChange :: (Show a, Eq a)
             => (a -> a)
             -> Handler b b a
             -> SnapHspecM b c
             -> SnapHspecM b ()
shouldChange :: (a -> a) -> Handler b b a -> SnapHspecM b c -> SnapHspecM b ()
shouldChange a -> a
f Handler b b a
v SnapHspecM b c
act = do a
before' <- Handler b b a -> SnapHspecM b a
forall b a. Handler b b a -> SnapHspecM b a
eval Handler b b a
v
                          SnapHspecM b c -> SnapHspecM b ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void SnapHspecM b c
act
                          a
after' <- Handler b b a -> SnapHspecM b a
forall b a. Handler b b a -> SnapHspecM b a
eval Handler b b a
v
                          a -> a -> SnapHspecM b ()
forall a b. (Show a, Eq a) => a -> a -> SnapHspecM b ()
shouldEqual (a -> a
f a
before') a
after'


-- | Asserts that two values are equal.
shouldEqual :: (Show a, Eq a)
            => a
            -> a
            -> SnapHspecM b ()
shouldEqual :: a -> a -> SnapHspecM b ()
shouldEqual a
a a
b = if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b
                      then ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
                      else ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (String
"Should have held: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" == " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
b))

-- | Asserts that two values are not equal.
shouldNotEqual :: (Show a, Eq a)
               => a
               -> a
               -> SnapHspecM b ()
shouldNotEqual :: a -> a -> SnapHspecM b ()
shouldNotEqual a
a a
b = if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b
                         then ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (String
"Should not have held: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" == " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
b))
                         else ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success

-- | Asserts that the value is True.
shouldBeTrue :: Bool
             -> SnapHspecM b ()
shouldBeTrue :: Bool -> SnapHspecM b ()
shouldBeTrue Bool
True = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
shouldBeTrue Bool
False = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
"Value should have been True.")

-- | Asserts that the value is not True (otherwise known as False).
shouldNotBeTrue :: Bool
                 -> SnapHspecM b ()
shouldNotBeTrue :: Bool -> SnapHspecM b ()
shouldNotBeTrue Bool
False = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
shouldNotBeTrue Bool
True = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
"Value should have been True.")

-- | Asserts that the response is a success (either Html, or Other with status 200).
should200 :: TestResponse -> SnapHspecM b ()
should200 :: TestResponse -> SnapHspecM b ()
should200 (Html RespCode
_ Text
_)   = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
should200 (Json RespCode
200 ByteString
_) = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
should200 (Other RespCode
200)  = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
should200 TestResponse
r = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (TestResponse -> String
forall a. Show a => a -> String
show TestResponse
r))

-- | Asserts that the response is not a normal 200.
shouldNot200 :: TestResponse -> SnapHspecM b ()
shouldNot200 :: TestResponse -> SnapHspecM b ()
shouldNot200 (Html RespCode
_ Text
_) = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
"Got Html back.")
shouldNot200 (Other RespCode
200) = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
"Got Other with 200 back.")
shouldNot200 TestResponse
_ = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success

-- | Asserts that the response is a NotFound.
should404 :: TestResponse -> SnapHspecM b ()
should404 :: TestResponse -> SnapHspecM b ()
should404 TestResponse
NotFound = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
should404 TestResponse
r = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (TestResponse -> String
forall a. Show a => a -> String
show TestResponse
r))

-- | Asserts that the response is not a NotFound.
shouldNot404 :: TestResponse -> SnapHspecM b ()
shouldNot404 :: TestResponse -> SnapHspecM b ()
shouldNot404 TestResponse
NotFound = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
"Got NotFound back.")
shouldNot404 TestResponse
_ = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success

-- | Asserts that the response is a redirect.
should300 :: TestResponse -> SnapHspecM b ()
should300 :: TestResponse -> SnapHspecM b ()
should300 (Redirect RespCode
_ Text
_) = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
should300 TestResponse
r = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (TestResponse -> String
forall a. Show a => a -> String
show TestResponse
r))

-- | Asserts that the response is not a redirect.
shouldNot300 :: TestResponse -> SnapHspecM b ()
shouldNot300 :: TestResponse -> SnapHspecM b ()
shouldNot300 (Redirect RespCode
_ Text
_) = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
"Got Redirect back.")
shouldNot300 TestResponse
_ = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success

-- | Asserts that the response is a redirect, and thet the url it
-- redirects to starts with the given path.
should300To :: Text -> TestResponse -> SnapHspecM b ()
should300To :: Text -> TestResponse -> SnapHspecM b ()
should300To Text
pth (Redirect RespCode
_ Text
to) | Text
pth Text -> Text -> Bool
`T.isPrefixOf` Text
to = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
should300To Text
_ TestResponse
r = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (TestResponse -> String
forall a. Show a => a -> String
show TestResponse
r))

-- | Asserts that the response is not a redirect to a given path. Note
-- that it can still be a redirect for this assertion to succeed, the
-- path it redirects to just can't start with the given path.
shouldNot300To :: Text -> TestResponse -> SnapHspecM b ()
shouldNot300To :: Text -> TestResponse -> SnapHspecM b ()
shouldNot300To Text
pth (Redirect RespCode
_ Text
to) | Text
pth Text -> Text -> Bool
`T.isPrefixOf` Text
to = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
"Got Redirect back.")
shouldNot300To Text
_ TestResponse
_ = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success

-- | Assert that a response (which should be Html) has a given selector.
shouldHaveSelector :: Text -> TestResponse -> SnapHspecM b ()
shouldHaveSelector :: Text -> TestResponse -> SnapHspecM b ()
shouldHaveSelector Text
selector r :: TestResponse
r@(Html RespCode
_ Text
body) =
  ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (ResultStatus -> SnapHspecM b ())
-> ResultStatus -> SnapHspecM b ()
forall a b. (a -> b) -> a -> b
$ if Text -> TestResponse -> Bool
haveSelector' Text
selector TestResponse
r
                then ResultStatus
Success
                else Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
msg
  where msg :: String
msg = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Html should have contained selector: ", Text
selector, Text
"\n\n", Text
body]
shouldHaveSelector Text
match TestResponse
_ = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Non-HTML body should have contained css selector: ", Text
match]))

-- | Assert that a response (which should be Html) doesn't have a given selector.
shouldNotHaveSelector :: Text -> TestResponse -> SnapHspecM b ()
shouldNotHaveSelector :: Text -> TestResponse -> SnapHspecM b ()
shouldNotHaveSelector Text
selector r :: TestResponse
r@(Html RespCode
_ Text
body) =
  ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (ResultStatus -> SnapHspecM b ())
-> ResultStatus -> SnapHspecM b ()
forall a b. (a -> b) -> a -> b
$ if Text -> TestResponse -> Bool
haveSelector' Text
selector TestResponse
r
                then Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
msg
                else ResultStatus
Success
  where msg :: String
msg = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Html should not have contained selector: ", Text
selector, Text
"\n\n", Text
body]
shouldNotHaveSelector Text
_ TestResponse
_ = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success

haveSelector' :: Text -> TestResponse -> Bool
haveSelector' :: Text -> TestResponse -> Bool
haveSelector' Text
selector (Html RespCode
_ Text
body) =
  case LA String XmlTree -> String -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXT.runLA (LA String XmlTree
forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
HXT.hread LA String XmlTree -> LA XmlTree XmlTree -> LA String XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
HXT.>>> String -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
HS.css (Text -> String
T.unpack Text
selector)) (Text -> String
T.unpack Text
body)  of
    [] -> Bool
False
    [XmlTree]
_ -> Bool
True
haveSelector' Text
_ TestResponse
_ = Bool
False

-- | Asserts that the response (which should be Html) contains the given text.
shouldHaveText :: Text -> TestResponse -> SnapHspecM b ()
shouldHaveText :: Text -> TestResponse -> SnapHspecM b ()
shouldHaveText Text
match (Html RespCode
_ Text
body) =
  if Text -> Text -> Bool
T.isInfixOf Text
match Text
body
  then ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
  else ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
body, Text
"' contains '", Text
match, Text
"'."])
shouldHaveText Text
match TestResponse
_ = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Body contains: ", Text
match]))

-- | Asserts that the response (which should be Html) does not contain the given text.
shouldNotHaveText :: Text -> TestResponse -> SnapHspecM b ()
shouldNotHaveText :: Text -> TestResponse -> SnapHspecM b ()
shouldNotHaveText Text
match (Html RespCode
_ Text
body) =
  if Text -> Text -> Bool
T.isInfixOf Text
match Text
body
  then ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
body, Text
"' contains '", Text
match, Text
"'."])
  else ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
shouldNotHaveText Text
_ TestResponse
_ = ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success


-- | A data type for tests against forms.
data FormExpectations a = Value a           -- ^ The value the form should take (and should be valid)
                        | Predicate (a -> Bool)
                        | ErrorPaths [Text] -- ^ The error paths that should be populated

-- | Tests against digestive-functors forms.
form :: (Eq a, Show a)
     => FormExpectations a           -- ^ If the form should succeed, Value a is what it should produce.
                                     --   If failing, ErrorPaths should be all the errors that are triggered.
     -> DF.Form Text (Handler b b) a -- ^ The form to run
     -> M.Map Text Text                -- ^ The parameters to pass
     -> SnapHspecM b ()
form :: FormExpectations a
-> Form Text (Handler b b) a -> Map Text Text -> SnapHspecM b ()
form FormExpectations a
expected Form Text (Handler b b) a
theForm Map Text Text
theParams =
  do (View Text, Maybe a)
r <- Handler b b (View Text, Maybe a)
-> SnapHspecM b (View Text, Maybe a)
forall b a. Handler b b a -> SnapHspecM b a
eval (Handler b b (View Text, Maybe a)
 -> SnapHspecM b (View Text, Maybe a))
-> Handler b b (View Text, Maybe a)
-> SnapHspecM b (View Text, Maybe a)
forall a b. (a -> b) -> a -> b
$ Text
-> Form Text (Handler b b) a
-> (FormEncType -> Handler b b (Env (Handler b b)))
-> Handler b b (View Text, Maybe a)
forall (m :: * -> *) v a.
Monad m =>
Text
-> Form v m a -> (FormEncType -> m (Env m)) -> m (View v, Maybe a)
DF.postForm Text
"form" Form Text (Handler b b) a
theForm (Handler b b (Env (Handler b b))
-> FormEncType -> Handler b b (Env (Handler b b))
forall a b. a -> b -> a
const (Handler b b (Env (Handler b b))
 -> FormEncType -> Handler b b (Env (Handler b b)))
-> Handler b b (Env (Handler b b))
-> FormEncType
-> Handler b b (Env (Handler b b))
forall a b. (a -> b) -> a -> b
$ Env (Handler b b) -> Handler b b (Env (Handler b b))
forall (m :: * -> *) a. Monad m => a -> m a
return Env (Handler b b)
lookupParam)
     case FormExpectations a
expected of
       Value a
a -> Maybe a -> Maybe a -> SnapHspecM b ()
forall a b. (Show a, Eq a) => a -> a -> SnapHspecM b ()
shouldEqual ((View Text, Maybe a) -> Maybe a
forall a b. (a, b) -> b
snd (View Text, Maybe a)
r) (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
       Predicate a -> Bool
f ->
         case (View Text, Maybe a) -> Maybe a
forall a b. (a, b) -> b
snd (View Text, Maybe a)
r of
           Maybe a
Nothing -> ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
                                 Text -> Text -> Text
T.append Text
"Expected form to validate. Resulted in errors: "
                                          (String -> Text
T.pack ([([Text], Text)] -> String
forall a. Show a => a -> String
show ([([Text], Text)] -> String) -> [([Text], Text)] -> String
forall a b. (a -> b) -> a -> b
$ View Text -> [([Text], Text)]
forall v. View v -> [([Text], v)]
DF.viewErrors (View Text -> [([Text], Text)]) -> View Text -> [([Text], Text)]
forall a b. (a -> b) -> a -> b
$ (View Text, Maybe a) -> View Text
forall a b. (a, b) -> a
fst (View Text, Maybe a)
r)))
           Just a
v -> if a -> Bool
f a
v
                       then ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
                       else ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
                                       Text -> Text -> Text
T.append Text
"Expected predicate to pass on value: "
                                                (String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
v)))
       ErrorPaths [Text]
expectedPaths ->
         do let viewErrorPaths :: [Text]
viewErrorPaths = (([Text], Text) -> Text) -> [([Text], Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Text] -> Text
DF.fromPath ([Text] -> Text)
-> (([Text], Text) -> [Text]) -> ([Text], Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text], Text) -> [Text]
forall a b. (a, b) -> a
fst) ([([Text], Text)] -> [Text]) -> [([Text], Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ View Text -> [([Text], Text)]
forall v. View v -> [([Text], v)]
DF.viewErrors (View Text -> [([Text], Text)]) -> View Text -> [([Text], Text)]
forall a b. (a -> b) -> a -> b
$ (View Text, Maybe a) -> View Text
forall a b. (a, b) -> a
fst (View Text, Maybe a)
r
            if (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
viewErrorPaths) [Text]
expectedPaths
               then if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
viewErrorPaths Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
expectedPaths
                       then ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult ResultStatus
Success
                       else ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ String
"Number of errors did not match test. Got:\n\n "
                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
viewErrorPaths
                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\nBut expected:\n\n"
                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
expectedPaths)
               else ResultStatus -> SnapHspecM b ()
forall b. ResultStatus -> SnapHspecM b ()
setResult (Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ String
"Did not have all errors specified. Got:\n\n"
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
viewErrorPaths
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\nBut expected:\n\n"
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
expectedPaths)
  where lookupParam :: Env (Handler b b)
lookupParam [Text]
pth = case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ([Text] -> Text
DF.fromPath [Text]
pth) Map Text Text
fixedParams of
                            Maybe Text
Nothing -> [FormInput] -> Handler b b [FormInput]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                            Just Text
v -> [FormInput] -> Handler b b [FormInput]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> FormInput
DF.TextInput Text
v]
        fixedParams :: Map Text Text
fixedParams = (Text -> Text) -> Map Text Text -> Map Text Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (Text -> Text -> Text
T.append Text
"form.") Map Text Text
theParams

-- | Runs a request (built with helpers from Snap.Test), resulting in a response.
runRequest :: RequestBuilder IO () -> SnapHspecM b TestResponse
runRequest :: RequestBuilder IO () -> SnapHspecM b TestResponse
runRequest RequestBuilder IO ()
req = do
  (SnapHspecState ResultStatus
_ Handler b b ()
site Snaplet b
app InitializerState b
is MVar [(Text, Text)]
_ Handler b b ()
bef Handler b b ()
aft) <- StateT (SnapHspecState b) IO (SnapHspecState b)
forall s (m :: * -> *). MonadState s m => m s
S.get
  Either Text Response
res <- IO (Either Text Response)
-> StateT (SnapHspecState b) IO (Either Text Response)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Response)
 -> StateT (SnapHspecState b) IO (Either Text Response))
-> IO (Either Text Response)
-> StateT (SnapHspecState b) IO (Either Text Response)
forall a b. (a -> b) -> a -> b
$ RequestBuilder IO ()
-> Handler b b ()
-> Snaplet b
-> InitializerState b
-> IO (Either Text Response)
forall b v.
RequestBuilder IO ()
-> Handler b b v
-> Snaplet b
-> InitializerState b
-> IO (Either Text Response)
runHandlerSafe RequestBuilder IO ()
req (Handler b b ()
bef Handler b b () -> Handler b b () -> Handler b b ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler b b ()
site Handler b b () -> Handler b b () -> Handler b b ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler b b ()
aft) Snaplet b
app InitializerState b
is
  case Either Text Response
res of
    Left Text
err ->
      String -> SnapHspecM b TestResponse
forall a. HasCallStack => String -> a
error (String -> SnapHspecM b TestResponse)
-> String -> SnapHspecM b TestResponse
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
err
    Right Response
response -> let respCode :: RespCode
respCode = Response -> RespCode
respStatus Response
response in
      case RespCode
respCode of
        RespCode
404 -> TestResponse -> SnapHspecM b TestResponse
forall (m :: * -> *) a. Monad m => a -> m a
return TestResponse
NotFound
        RespCode
200 ->
          IO TestResponse -> SnapHspecM b TestResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TestResponse -> SnapHspecM b TestResponse)
-> IO TestResponse -> SnapHspecM b TestResponse
forall a b. (a -> b) -> a -> b
$ Response -> IO TestResponse
parse200 Response
response
        RespCode
_ -> if RespCode
respCode RespCode -> RespCode -> Bool
forall a. Ord a => a -> a -> Bool
>= RespCode
300 Bool -> Bool -> Bool
&& RespCode
respCode RespCode -> RespCode -> Bool
forall a. Ord a => a -> a -> Bool
< RespCode
400
                then do let url :: ByteString
url = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Response -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"Location" Response
response
                        TestResponse -> SnapHspecM b TestResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (RespCode -> Text -> TestResponse
Redirect RespCode
respCode (ByteString -> Text
T.decodeUtf8 ByteString
url))
                else TestResponse -> SnapHspecM b TestResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (RespCode -> TestResponse
Other RespCode
respCode)

respStatus :: Response -> RespCode
respStatus :: Response -> RespCode
respStatus = Int -> RespCode
RespCode (Int -> RespCode) -> (Response -> Int) -> Response -> RespCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Int
rspStatus


parse200 :: Response -> IO TestResponse
parse200 :: Response -> IO TestResponse
parse200 Response
resp =
    let body :: IO ByteString
body        = Response -> IO ByteString
getResponseBody Response
resp
        contentType :: Maybe ByteString
contentType = CI ByteString -> Response -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"content-type" Response
resp in
    case Maybe ByteString
contentType of
      Just ByteString
"application/json" -> RespCode -> ByteString -> TestResponse
Json RespCode
200 (ByteString -> TestResponse)
-> (ByteString -> ByteString) -> ByteString -> TestResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict (ByteString -> TestResponse) -> IO ByteString -> IO TestResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
body
      Maybe ByteString
_                       -> RespCode -> Text -> TestResponse
Html RespCode
200 (Text -> TestResponse)
-> (ByteString -> Text) -> ByteString -> TestResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> TestResponse) -> IO ByteString -> IO TestResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
body

-- | Runs a request against a given handler (often the whole site),
-- with the given state. Returns any triggered exception, or the response.
runHandlerSafe :: RequestBuilder IO ()
               -> Handler b b v
               -> Snaplet b
               -> InitializerState b
               -> IO (Either Text Response)
runHandlerSafe :: RequestBuilder IO ()
-> Handler b b v
-> Snaplet b
-> InitializerState b
-> IO (Either Text Response)
runHandlerSafe RequestBuilder IO ()
req Handler b b v
site Snaplet b
s InitializerState b
is =
  IO (Either Text Response)
-> (SomeException -> IO (Either Text Response))
-> IO (Either Text Response)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Snaplet b
-> InitializerState b
-> RequestBuilder IO ()
-> Handler b b v
-> IO (Either Text Response)
forall (m :: * -> *) b v.
MonadIO m =>
Snaplet b
-> InitializerState b
-> RequestBuilder m ()
-> Handler b b v
-> m (Either Text Response)
runHandler' Snaplet b
s InitializerState b
is RequestBuilder IO ()
req Handler b b v
site) (\(SomeException
e::SomeException) -> Either Text Response -> IO (Either Text Response)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Response -> IO (Either Text Response))
-> Either Text Response -> IO (Either Text Response)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Response
forall a b. a -> Either a b
Left (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e))

-- | Evaluates a given handler with the given state. Returns any
-- triggered exception, or the value produced.
evalHandlerSafe :: Handler b b v
                -> Snaplet b
                -> InitializerState b
                -> IO (Either Text v)
evalHandlerSafe :: Handler b b v
-> Snaplet b -> InitializerState b -> IO (Either Text v)
evalHandlerSafe Handler b b v
act Snaplet b
s InitializerState b
is =
  IO (Either Text v)
-> (SomeException -> IO (Either Text v)) -> IO (Either Text v)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Snaplet b
-> InitializerState b
-> RequestBuilder IO ()
-> Handler b b v
-> IO (Either Text v)
forall (m :: * -> *) b a.
MonadIO m =>
Snaplet b
-> InitializerState b
-> RequestBuilder m ()
-> Handler b b a
-> m (Either Text a)
evalHandler' Snaplet b
s InitializerState b
is (ByteString -> Params -> RequestBuilder IO ()
forall (m :: * -> *).
MonadIO m =>
ByteString -> Params -> RequestBuilder m ()
Test.get ByteString
"" Params
forall k a. Map k a
M.empty) Handler b b v
act) (\(SomeException
e::SomeException) -> Either Text v -> IO (Either Text v)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text v -> IO (Either Text v))
-> Either Text v -> IO (Either Text v)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text v
forall a b. a -> Either a b
Left (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e))

{-# ANN put ("HLint: ignore Eta reduce"::String)                            #-}