Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added postJSON function and JSONPostRequest RequestType.

  • Loading branch information...
commit 002c4ccccfaf2e23a3dad7190a859cb214973987 1 parent 6e9f4e6
Alexander Kjeldaas authored
27 src/Snap/Internal/Test/RequestBuilder.hs
View
@@ -17,6 +17,7 @@ module Snap.Internal.Test.RequestBuilder
, evalHandlerM
, get
, postMultipart
+ , postJSON
, postRaw
, postUrlEncoded
, put
@@ -179,12 +180,13 @@ data FileData = FileData {
------------------------------------------------------------------------------
-- | The 'RequestType' datatype enumerates the different kinds of HTTP
--- requests you can generate using the testing interface. Most users will
--- prefer to use the 'get', 'postUrlEncoded', 'postMultipart', 'put', and
--- 'delete' convenience functions.
+-- requests you can generate using the testing interface. Most users
+-- will prefer to use the 'get', 'postUrlEncoded', 'postMultipart',
+-- 'postJSON', 'put', and 'delete' convenience functions.
data RequestType
= GetRequest
| RequestWithRawBody Method ByteString
+ | JSONPostRequest ByteString
| MultipartPostRequest MultipartParams
| UrlEncodedPostRequest Params
| DeleteRequest
@@ -215,6 +217,14 @@ setRequestType (RequestWithRawBody m b) = do
, rqContentLength = Just $ S.length b
}
+setRequestType (JSONPostRequest b) = do
+ rq <- liftM (H.setHeader "Content-Type"
+ "application/json") rGet
+ liftIO $ writeIORef (rqBody rq) $ SomeEnumerator $ enumBS b
+ rPut $ rq { rqMethod = POST
+ , rqContentLength = Just $ S.length b
+ }
+
setRequestType (MultipartPostRequest fp) = encodeMultipart fp
setRequestType (UrlEncodedPostRequest fp) = do
@@ -512,6 +522,17 @@ postMultipart uri params = do
setRequestType $ MultipartPostRequest params
setRequestPath uri
+------------------------------------------------------------------------------
+-- | Builds an HTTP \"POST\" request with the given JSON content, using the
+-- \"application/json\" MIME type.
+postJSON :: MonadIO m =>
+ ByteString -- ^ request path
+ -> ByteString -- ^ JSON content
+ -> RequestBuilder m ()
+postJSON uri content = do
+ setRequestType $ JSONPostRequest content
+ setRequestPath uri
+
------------------------------------------------------------------------------
-- | Builds an HTTP \"PUT\" request.
1  src/Snap/Test.hs
View
@@ -21,6 +21,7 @@ module Snap.Test
, get
, postUrlEncoded
, postMultipart
+ , postJSON
, put
, postRaw
, delete
18 test/suite/Snap/Test/Tests.hs
View
@@ -33,6 +33,7 @@ tests = [ testSetRequestType
, testMisc
, testMultipart
, testPost
+ , testPostJSON
, testToString
, testAssert404
, testAssertBodyContains
@@ -69,6 +70,12 @@ testSetRequestType = testCase "test/requestBuilder/setRequestType" $ do
request7 <- buildRequest $ setRequestType $ RequestWithRawBody PATCH "bar"
assertEqual "setRequestType/7/Method" PATCH (rqMethod request7)
+ request8 <- buildRequest $ setRequestType $
+ JSONPostRequest "{\"a\":\"b\"}"
+ assertEqual "setRequestType/8/Method" POST (rqMethod request8)
+ assertEqual "setRequestType/8/Content-Type"
+ (Just "application/json") $ T.getHeader "Content-Type" request8
+
where
rt4 = MultipartPostRequest [ ("foo", FormData ["foo"])
, ("bar", Files [fd4])
@@ -227,6 +234,17 @@ testPost = testCase "test/requestBuilder/testPost" $ do
getHeader "Content-Type" request
+testPostJSON :: Test
+testPostJSON = testCase "test/requestBuilder/testPostJSON" $ do
+ request <-buildRequest $ do
+ postJSON "/api/login" "{\"a\":\"b\"}"
+
+ body <- getRqBody request
+ assertEqual "body" "{\"a\":\"b\"}" body
+ assertEqual "len" (Just (S.length body)) $ rqContentLength request
+ assertEqual "contentType" (Just "application/json") $
+ getHeader "Content-Type" request
+
------------------------------------------------------------------------------
testToString :: Test
testToString = testCase "test/requestBuilder/testToString" $ do
Please sign in to comment.
Something went wrong with that request. Please try again.