From 3655af11d3be0fdece443706bbc96ea9c52b458d Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Tue, 30 Jul 2013 11:11:34 +0300 Subject: [PATCH] Use GADTs for static guarantee you use right type of post data. --- yesod-test/Yesod/Test.hs | 84 ++++++++++++++++++++++++---------------- 1 file changed, 51 insertions(+), 33 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 74bdcc02..0d589104 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} {-| Yesod.Test is a pragmatic framework for testing web applications built using wai and persistent. @@ -165,8 +166,8 @@ getTestYesod = fmap yedSite ST.get getResponse :: YesodExample site (Maybe SResponse) getResponse = fmap yedResponse ST.get -data RequestBuilderData site = RequestBuilderData - { rbdPostData :: RBDPostData +data RequestBuilderData site p = RequestBuilderData + { rbdPostData :: Maybe (RBDPostData p) , rbdResponse :: (Maybe SResponse) , rbdMethod :: H.Method , rbdSite :: site @@ -175,8 +176,9 @@ data RequestBuilderData site = RequestBuilderData , rbdHeaders :: H.RequestHeaders } -data RBDPostData = MultipleItemsPostData [RequestPart] - | BinaryPostData BSL8.ByteString +data RBDPostData a where + MultipleItemsPostData :: [RequestPart] -> RBDPostData [RequestPart] + BinaryPostData :: BSL8.ByteString -> RBDPostData BSL8.ByteString -- | Request parts let us discern regular key/values from files sent in the request. data RequestPart @@ -186,7 +188,7 @@ data RequestPart -- | The RequestBuilder state monad constructs an url encoded string of arguments -- to send with your requests. Some of the functions that run on it use the current -- response to analize the forms that the server is expecting to receive. -type RequestBuilder site = ST.StateT (RequestBuilderData site) IO +type RequestBuilder site p = ST.StateT (RequestBuilderData site p) IO -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- and 'ConnectionPool' @@ -372,14 +374,16 @@ printMatches query = do liftIO $ hPutStrLn stderr $ show matches -- | Add a parameter with the given name and value. -addPostParam :: T.Text -> T.Text -> RequestBuilder site () +addPostParam :: T.Text -> T.Text -> RequestBuilder site [RequestPart] () addPostParam name value = ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) } - where addPostData x@(BinaryPostData _) = x - addPostData (MultipleItemsPostData posts) = - MultipleItemsPostData $ ReqKvPart name value : posts + where addPostData :: Maybe (RBDPostData [RequestPart]) + -> Maybe (RBDPostData [RequestPart]) + addPostData (Just (MultipleItemsPostData posts)) = + Just $ MultipleItemsPostData $ ReqKvPart name value : posts + addPostData Nothing = Just $ MultipleItemsPostData $ [ReqKvPart name value] -addGetParam :: T.Text -> T.Text -> RequestBuilder site () +addGetParam :: T.Text -> T.Text -> RequestBuilder site p () addGetParam name value = ST.modify $ \rbd -> rbd { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value) : rbdGets rbd @@ -388,16 +392,20 @@ addGetParam name value = ST.modify $ \rbd -> rbd -- | Add a file to be posted with the current request -- -- Adding a file will automatically change your request content-type to be multipart/form-data -addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site () +addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site [RequestPart] () addFile name path mimetype = do contents <- liftIO $ BSL8.readFile path ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) } - where addPostData x@(BinaryPostData _) _ = x - addPostData (MultipleItemsPostData posts) contents = - MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts + where addPostData :: Maybe (RBDPostData [RequestPart]) + -> BSL8.ByteString + -> Maybe (RBDPostData [RequestPart]) + addPostData (Just (MultipleItemsPostData posts)) contents = + Just $ MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts + addPostData Nothing contents = + Just $ MultipleItemsPostData $ [ReqFilePart name path contents mimetype] -- This looks up the name of a field based on the contents of the label pointing to it. -nameFromLabel :: T.Text -> RequestBuilder site T.Text +nameFromLabel :: T.Text -> RequestBuilder site p T.Text nameFromLabel label = do mres <- fmap rbdResponse ST.get res <- @@ -436,19 +444,19 @@ nameFromLabel label = do (<>) :: T.Text -> T.Text -> T.Text (<>) = T.append -byLabel :: T.Text -> T.Text -> RequestBuilder site () +byLabel :: T.Text -> T.Text -> RequestBuilder site [RequestPart] () byLabel label value = do name <- nameFromLabel label addPostParam name value -fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site () +fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site [RequestPart] () fileByLabel label path mime = do name <- nameFromLabel label addFile name path mime -- | Lookup a _nonce form field and add it's value to the params. -- Receives a CSS selector that should resolve to the form element containing the nonce. -addNonce_ :: Query -> RequestBuilder site () +addNonce_ :: Query -> RequestBuilder site [RequestPart] () addNonce_ scope = do matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]" case matches of @@ -457,7 +465,7 @@ addNonce_ scope = do _ -> failure $ "More than one nonce found in the page" -- | For responses that display a single form, just lookup the only nonce available. -addNonce :: RequestBuilder site () +addNonce :: RequestBuilder site [RequestPart] () addNonce = addNonce_ "" -- | Perform a POST request to url @@ -486,12 +494,12 @@ get url = request $ do setMethod "GET" setUrl url -setMethod :: H.Method -> RequestBuilder site () +setMethod :: H.Method -> RequestBuilder site p () setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m } setUrl :: (Yesod site, RedirectUrl site url) => url - -> RequestBuilder site () + -> RequestBuilder site p () setUrl url' = do site <- fmap rbdSite ST.get eurl <- runFakeHandler @@ -513,10 +521,10 @@ setUrl url' = do -- | Simple way to set HTTP request body setRequestBody :: (Yesod site) => BSL8.ByteString - -> RequestBuilder site () -setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body } + -> RequestBuilder site BSL8.ByteString () +setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = Just (BinaryPostData body) } -addRequestHeader :: H.Header -> RequestBuilder site () +addRequestHeader :: H.Header -> RequestBuilder site p () addRequestHeader header = ST.modify $ \rbd -> rbd { rbdHeaders = header : rbdHeaders rbd } @@ -524,13 +532,13 @@ addRequestHeader header = ST.modify $ \rbd -> rbd -- | General interface to performing requests, allowing you to add extra -- headers as well as letting you specify the request method. request :: Yesod site - => RequestBuilder site () + => RequestBuilder site p () -> YesodExample site () request reqBuilder = do YesodExampleData app site oldCookies mRes <- ST.get RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData - { rbdPostData = MultipleItemsPostData [] + { rbdPostData = Nothing , rbdResponse = mRes , rbdMethod = "GET" , rbdSite = site @@ -546,11 +554,12 @@ request reqBuilder = do cookiesForPath = M.filter (checkCookiePath path) cookies let maker = case rbdPostData of - MultipleItemsPostData x -> + Just (MultipleItemsPostData x) -> if DL.any isFile x then makeMultipart else makeSinglepart - BinaryPostData _ -> makeSinglepart + Just (BinaryPostData _) -> makeSinglepart + Nothing -> makeSinglepart let req = maker cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets response <- liftIO $ runSession (srequest req) app let newCookies = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders response @@ -572,11 +581,19 @@ request reqBuilder = do boundary :: String boundary = "*******noneedtomakethisrandom" separator = BS8.concat ["--", BS8.pack boundary, "\r\n"] + makeMultipart :: M.Map a0 Cookie.SetCookie + -> Maybe (RBDPostData [RequestPart]) + -> H.Method + -> [H.Header] + -> T.Text + -> H.Query + -> SRequest makeMultipart cookies rbdPostData method extraHeaders urlPath urlQuery = SRequest simpleRequest' (simpleRequestBody' rbdPostData) - where simpleRequestBody' (MultipleItemsPostData x) = + where simpleRequestBody' :: Maybe (RBDPostData [RequestPart]) -> BSL8.ByteString + simpleRequestBody' (Just (MultipleItemsPostData x)) = BSL8.fromChunks [multiPartBody x] - simpleRequestBody' (BinaryPostData _) = "" + simpleRequestBody' Nothing = "" simpleRequest' = mkRequest [ ("Cookie", cookieValue) , ("Content-Type", contentTypeValue)] @@ -600,7 +617,7 @@ request reqBuilder = do -- For building the regular non-multipart requests makeSinglepart :: M.Map a0 Cookie.SetCookie - -> RBDPostData + -> Maybe (RBDPostData p) -> H.Method -> [H.Header] -> T.Text @@ -613,10 +630,11 @@ request reqBuilder = do [ ("Cookie", cookieValue) , ("Content-Type", "application/x-www-form-urlencoded")] method extraHeaders urlPath urlQuery) - simpleRequestBody' (MultipleItemsPostData x) = + simpleRequestBody' (Just (MultipleItemsPostData x)) = BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart x - simpleRequestBody' (BinaryPostData x) = x + simpleRequestBody' (Just (BinaryPostData x)) = x + simpleRequestBody' Nothing = "" cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies ]