diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,5 @@ +0.3.2.5 - 2015-4-22 - Add support for `PUT` and `DELETE`. + 0.3.2.4 - 2015-4-9 - Loosen lens bound and remove snap-extras dependency. 0.3.2.3 - 2015-2-27 - Loosen hspec bound. diff --git a/hspec-snap.cabal b/hspec-snap.cabal --- a/hspec-snap.cabal +++ b/hspec-snap.cabal @@ -1,5 +1,5 @@ name: hspec-snap -version: 0.3.2.4 +version: 0.3.2.5 synopsis: A library for testing with Hspec and the Snap Web Framework homepage: https://github.com/dbp/hspec-snap license: BSD3 @@ -54,4 +54,4 @@ , text >= 0.11 && < 1.3 , transformers >= 0.3 && < 0.5 , directory >= 1.2 && < 1.3 - build-depends: hspec-snap == 0.3.2.4 + build-depends: hspec-snap == 0.3.2.5 diff --git a/spec/Main.hs b/spec/Main.hs --- a/spec/Main.hs +++ b/spec/Main.hs @@ -25,6 +25,7 @@ ,toJSON, parseJSON) import qualified Data.Aeson as Ae ((.:)) import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (concat) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe) @@ -82,7 +83,7 @@ getSessionLens = sess html :: Text -html = "
OneTwo
" +html = "
OneTwo
" testForm :: Form Text (Handler App App) (Text, Text) testForm = (,) <$> "a" .: check "Should not be empty" (\t -> not $ T.null t) (text Nothing) @@ -103,11 +104,21 @@ exampleObj :: ExampleObject exampleObj = ExampleObject 42 "foo" +writeParamsAndMethod :: Maybe ByteString -> Snap.Method -> Handler App App () +writeParamsAndMethod mq m = case m of + POST -> writeBS $ methodAndParam "POST " + PUT -> writeBS $ methodAndParam "PUT " + _ -> writeBS "Not valid" + where + methodAndParam p = BS.concat [p, fromMaybe "" mq] + routes :: [(ByteString, Handler App App ())] routes = [("/test", method GET $ writeText html) ,("/test", method POST $ writeText "") + ,("/test", method DELETE $ writeText "deleted") + ,("/test", method PUT $ writeText "") ,("/params", do mq <- getParam "q" - writeBS $ fromMaybe "" mq) + writeParamsAndMethod mq =<< (Snap.rqMethod <$> Snap.getRequest)) ,("/redirect", Snap.redirect "/test") ,("/setmv", do m <- use mv void $ liftIO $ tryPutMVar m () @@ -118,7 +129,7 @@ ,("/getsess/:k", do Just k <- fmap T.decodeUtf8 <$> getParam "k" Just r <- with sess $ getFromSession k writeText r) - ,("/json", do writeJSON $ exampleObj) + ,("/json", writeJSON $ exampleObj) ] app :: MVar (Map Int Foo) -> MVar () -> SnapletInit App App @@ -151,11 +162,18 @@ shouldNotHaveSelector "table td.doesntexist" p get "/redirect" >>= shouldNotHaveSelector "table td.doesntexist" get "/invalid_url" >>= shouldNotHaveSelector "table td.doesntexist" + it "should have deleted as text on the response" $ + delete "/test" >>= shouldHaveText "deleted" it "should not match on POST request" $ post "/test" M.empty >>= shouldNotHaveText "" it "should post parameters" $ do - post "/params" (params [("q", "hello")]) >>= shouldHaveText "hello" + post "/params" (params [("q", "hello")]) >>= shouldHaveText "POST hello" post "/params" (params [("r", "hello")]) >>= shouldNotHaveText "hello" + it "should not match on PUT request" $ + put "/test" M.empty >>= shouldNotHaveText "" + it "should put parameters" $ do + put "/params" (params [("q", "hello")]) >>= shouldHaveText "PUT hello" + put "/params" (params [("r", "hello")]) >>= shouldNotHaveText "hello" it "basic equality" $ do eval (return 1) >>= shouldEqual 1 shouldNotEqual 1 2 diff --git a/src/Test/Hspec/Snap.hs b/src/Test/Hspec/Snap.hs --- a/src/Test/Hspec/Snap.hs +++ b/src/Test/Hspec/Snap.hs @@ -25,9 +25,12 @@ , Factory(..) -- * Requests + , delete , get , get' , post + , put + , put' , params -- * Helpers for dealing with TestResponses @@ -271,6 +274,10 @@ ++ "\n\nSession was:\n" ++ (T.unpack contents)) else setResult Success +-- | Runs a DELETE request +delete :: Text -> SnapHspecM b TestResponse +delete path = runRequest (Test.delete (T.encodeUtf8 path) M.empty) + -- | Runs a GET request. get :: Text -> SnapHspecM b TestResponse get path = get' path M.empty @@ -287,6 +294,16 @@ -- | Creates a new POST request, with a set of parameters. post :: Text -> Snap.Params -> SnapHspecM b TestResponse post path ps = runRequest (Test.postUrlEncoded (T.encodeUtf8 path) ps) + +-- | 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 path params = put' path "application/x-www-form-urlencoded" params + +-- | Creates a new PUT request with a configurable MIME/type +put' :: Text -> Text -> Snap.Params -> SnapHspecM b TestResponse +put' path mime params = runRequest $ do + Test.put (T.encodeUtf8 path) (T.encodeUtf8 mime) "" + Test.setQueryString params -- | Restricts a response to matches for a given CSS selector. -- Does nothing to non-Html responses.