module Test.Tasty.Wai
(
Sess (..)
, testWai
, get
, head
, post
, postWithHeaders
, put
, assertStatus'
, buildRequest
, buildRequestWithBody
, buildRequestWithHeaders
, module Network.Wai.Test
) where
import qualified Control.Exception as E
import Prelude hiding (head)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Monoid ((<>))
import Network.HTTP.Types (RequestHeaders, StdMethod)
import qualified Network.HTTP.Types as HTTP
import Test.HUnit.Lang (HUnitFailure (HUnitFailure),
formatFailureReason)
import Test.Tasty.Providers (IsTest (..), Progress (..), TestName,
TestTree, singleTest, testFailed,
testPassed)
import Test.Tasty.Runners (formatMessage)
import Network.Wai (Application, Request, requestHeaders,
requestMethod)
import Network.Wai.Test
data Sess
= S Application TestName (Session ())
instance IsTest Sess where
testOptions :: Tagged Sess [OptionDescription]
testOptions = Tagged Sess [OptionDescription]
forall a. Monoid a => a
mempty
run :: OptionSet -> Sess -> (Progress -> IO ()) -> IO Result
run OptionSet
_ (S Application
app TestName
tName Session ()
sess) Progress -> IO ()
yieldProgress = do
Progress -> IO ()
yieldProgress (Progress -> IO ()) -> Progress -> IO ()
forall a b. (a -> b) -> a -> b
$ TestName -> Float -> Progress
Progress (TestName
"Running " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
tName) Float
0
IO () -> IO (Either HUnitFailure ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try (Session () -> Application -> IO ()
forall a. Session a -> Application -> IO a
runSession Session ()
sess Application
app) IO (Either HUnitFailure ())
-> (Either HUnitFailure () -> IO Result) -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (HUnitFailure -> IO Result)
-> (() -> IO Result) -> Either HUnitFailure () -> IO Result
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HUnitFailure -> IO Result
toFailure () -> IO Result
forall (f :: * -> *) p. Applicative f => p -> f Result
toPass
where
toFailure :: HUnitFailure -> IO Result
toFailure (HUnitFailure Maybe SrcLoc
_ FailureReason
s) = TestName -> Result
testFailed (TestName -> Result) -> IO TestName -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TestName -> IO TestName
formatMessage (FailureReason -> TestName
formatFailureReason FailureReason
s))
toPass :: p -> f Result
toPass p
_ = Result -> f Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestName -> Result
testPassed TestName
forall a. Monoid a => a
mempty)
buildRequest
:: StdMethod
-> BS.ByteString
-> Request
buildRequest :: StdMethod -> ByteString -> Request
buildRequest StdMethod
mth ByteString
rpath = (Request -> ByteString -> Request)
-> ByteString -> Request -> Request
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> ByteString -> Request
setPath ByteString
rpath (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
defaultRequest
{ requestMethod :: ByteString
requestMethod = StdMethod -> ByteString
HTTP.renderStdMethod StdMethod
mth
}
buildRequestWithBody
:: StdMethod
-> BS.ByteString
-> LBS.ByteString
-> SRequest
buildRequestWithBody :: StdMethod -> ByteString -> ByteString -> SRequest
buildRequestWithBody StdMethod
mth ByteString
rpath =
Request -> ByteString -> SRequest
SRequest (StdMethod -> ByteString -> Request
buildRequest StdMethod
mth ByteString
rpath)
buildRequestWithHeaders
:: StdMethod
-> BS.ByteString
-> LBS.ByteString
-> RequestHeaders
-> SRequest
StdMethod
mthd ByteString
pth ByteString
bdy RequestHeaders
hdrs =
SRequest
rq { simpleRequest :: Request
simpleRequest = (SRequest -> Request
simpleRequest SRequest
rq) { requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
hdrs } }
where rq :: SRequest
rq = StdMethod -> ByteString -> ByteString -> SRequest
buildRequestWithBody StdMethod
mthd ByteString
pth ByteString
bdy
testWai :: Application -> TestName -> Session () -> TestTree
testWai :: Application -> TestName -> Session () -> TestTree
testWai Application
a TestName
tn = TestName -> Sess -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
singleTest TestName
tn (Sess -> TestTree)
-> (Session () -> Sess) -> Session () -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Application -> TestName -> Session () -> Sess
S Application
a TestName
tn
head :: BS.ByteString -> Session SResponse
head :: ByteString -> Session SResponse
head = Request -> Session SResponse
request (Request -> Session SResponse)
-> (ByteString -> Request) -> ByteString -> Session SResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> ByteString -> Request
buildRequest StdMethod
HTTP.HEAD
get :: BS.ByteString -> Session SResponse
get :: ByteString -> Session SResponse
get = Request -> Session SResponse
request (Request -> Session SResponse)
-> (ByteString -> Request) -> ByteString -> Session SResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> ByteString -> Request
buildRequest StdMethod
HTTP.GET
post :: BS.ByteString -> LBS.ByteString -> Session SResponse
post :: ByteString -> ByteString -> Session SResponse
post ByteString
r = SRequest -> Session SResponse
srequest (SRequest -> Session SResponse)
-> (ByteString -> SRequest) -> ByteString -> Session SResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> ByteString -> ByteString -> SRequest
buildRequestWithBody StdMethod
HTTP.POST ByteString
r
postWithHeaders :: BS.ByteString -> LBS.ByteString -> RequestHeaders -> Session SResponse
ByteString
path ByteString
body RequestHeaders
headers = SRequest -> Session SResponse
srequest (SRequest -> Session SResponse) -> SRequest -> Session SResponse
forall a b. (a -> b) -> a -> b
$ StdMethod -> ByteString -> ByteString -> RequestHeaders -> SRequest
buildRequestWithHeaders StdMethod
HTTP.POST ByteString
path ByteString
body RequestHeaders
headers
put :: BS.ByteString -> LBS.ByteString -> Session SResponse
put :: ByteString -> ByteString -> Session SResponse
put ByteString
r = SRequest -> Session SResponse
srequest (SRequest -> Session SResponse)
-> (ByteString -> SRequest) -> ByteString -> Session SResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> ByteString -> ByteString -> SRequest
buildRequestWithBody StdMethod
HTTP.PUT ByteString
r
assertStatus' :: HTTP.Status -> SResponse -> Session ()
assertStatus' :: Status -> SResponse -> Session ()
assertStatus' Status
c = HasCallStack => Int -> SResponse -> Session ()
Int -> SResponse -> Session ()
assertStatus (Status -> Int
HTTP.statusCode Status
c)