Added postJSON function and JSONPostRequest RequestType.

src/Snap/Internal/Test/RequestBuilder.hs

@@ -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.

src/Snap/Test.hs

@@ -21,6 +21,7 @@ module Snap.Test
   , get
   , postUrlEncoded
   , postMultipart
+  , postJSON
   , put
   , postRaw
   , delete

test/suite/Snap/Test/Tests.hs

@@ -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