haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Remove hxt dep from yesod-test (#382)

Browse Source
This commit is contained in:
Michael Snoyman 2012-07-09 14:15:10 +03:00
parent 288f3b36eb
commit 0dbd724155
2 changed files with 58 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
yesod-test/Yesod/Test.hs
View File

@ -78,7 +78,6 @@ import qualified Test.Hspec.HUnit ()
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.Socket.Internal as Sock import qualified Network.Socket.Internal as Sock
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Text.XML.HXT.Core hiding (app, err)
import Network.Wai import Network.Wai
import Network.Wai.Test hiding (assertHeader, assertNoHeader) import Network.Wai.Test hiding (assertHeader, assertNoHeader)
import qualified Control.Monad.Trans.State as ST import qualified Control.Monad.Trans.State as ST
@ -89,6 +88,8 @@ import Database.Persist.GenericSql
import Data.Monoid (mappend) import Data.Monoid (mappend)
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
import Text.XML.Cursor hiding (element)
import qualified Text.HTML.DOM as HD
-- | The state used in 'describe' to build a list of specs -- | The state used in 'describe' to build a list of specs
data SpecsData = SpecsData Application ConnectionPool [Core.Spec] data SpecsData = SpecsData Application ConnectionPool [Core.Spec]
@ -106,8 +107,8 @@ data RequestBuilderData = RequestBuilderData [RequestPart] (Maybe SResponse)
-- | Request parts let us discern regular key/values from files sent in the request. -- | Request parts let us discern regular key/values from files sent in the request.
data RequestPart data RequestPart
= ReqPlainPart String String = ReqPlainPart T.Text T.Text
| ReqFilePart String FilePath BSL8.ByteString String | ReqFilePart T.Text FilePath BSL8.ByteString T.Text
-- | The RequestBuilder state monad constructs an url encoded string of arguments -- | 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 -- to send with your requests. Some of the functions that run on it use the current
@ -164,14 +165,14 @@ withResponse f = maybe err f =<< fmap readResponse ST.get
-- | Use HXT to parse a value from an html tag. -- | Use HXT to parse a value from an html tag.
-- Check for usage examples in this module's source. -- Check for usage examples in this module's source.
parseHTML :: Html -> LA XmlTree a -> [a] parseHTML :: Html -> (Cursor -> [a]) -> [a]
parseHTML html p = runLA (hread >>> p ) (TL.unpack $ decodeUtf8 html) parseHTML html p = p $ fromDocument $ HD.parseLBS html
-- | Query the last response using css selectors, returns a list of matched fragments -- | Query the last response using css selectors, returns a list of matched fragments
htmlQuery :: HoldsResponse a => Query -> ST.StateT a IO [Html] htmlQuery :: HoldsResponse a => Query -> ST.StateT a IO [Html]
htmlQuery query = withResponse $ \ res -> htmlQuery query = withResponse $ \ res ->
case findBySelector (simpleBody res) query of case findBySelector (simpleBody res) query of
Left err -> failure $ T.unpack query ++ " did not parse: " ++ (show err) Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
Right matches -> return $ map (encodeUtf8 . TL.pack) matches Right matches -> return $ map (encodeUtf8 . TL.pack) matches
-- | Asserts that the two given values are equal. -- | Asserts that the two given values are equal.
@ -190,7 +191,7 @@ statusIs number = withResponse $ \ SResponse { simpleStatus = s } ->
assertHeader :: HoldsResponse a => CI BS8.ByteString -> BS8.ByteString -> ST.StateT a IO () assertHeader :: HoldsResponse a => CI BS8.ByteString -> BS8.ByteString -> ST.StateT a IO ()
assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } -> assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->
case lookup header h of case lookup header h of
Nothing -> failure $ concat Nothing -> failure $ T.pack $ concat
[ "Expected header " [ "Expected header "
, show header , show header
, " to be " , " to be "
@ -211,7 +212,7 @@ assertNoHeader :: HoldsResponse a => CI BS8.ByteString -> ST.StateT a IO ()
assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } -> assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
case lookup header h of case lookup header h of
Nothing -> return () Nothing -> return ()
Just s -> failure $ concat Just s -> failure $ T.pack $ concat
[ "Unexpected header " [ "Unexpected header "
, show header , show header
, " containing " , " containing "
@ -241,7 +242,7 @@ htmlAllContain :: HoldsResponse a => Query -> String -> ST.StateT a IO ()
htmlAllContain query search = do htmlAllContain query search = do
matches <- htmlQuery query matches <- htmlQuery query
case matches of case matches of
[] -> failure $ "Nothing matched css query: "++T.unpack query [] -> failure $ "Nothing matched css query: " <> query
_ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $ _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $
DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
@ -265,7 +266,7 @@ printMatches query = do
liftIO $ hPutStrLn stderr $ show matches liftIO $ hPutStrLn stderr $ show matches
-- | Add a parameter with the given name and value. -- | Add a parameter with the given name and value.
byName :: String -> String -> RequestBuilder () byName :: T.Text -> T.Text -> RequestBuilder ()
byName name value = do byName name value = do
RequestBuilderData parts r <- ST.get RequestBuilderData parts r <- ST.get
ST.put $ RequestBuilderData ((ReqPlainPart name value):parts) r ST.put $ RequestBuilderData ((ReqPlainPart name value):parts) r
@ -273,50 +274,67 @@ byName name value = do
-- | Add a file to be posted with the current request -- | 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 -- Adding a file will automatically change your request content-type to be multipart/form-data
fileByName :: String -> FilePath -> String -> RequestBuilder () fileByName :: T.Text -> FilePath -> T.Text -> RequestBuilder ()
fileByName name path mimetype = do fileByName name path mimetype = do
RequestBuilderData parts r <- ST.get RequestBuilderData parts r <- ST.get
contents <- liftIO $ BSL8.readFile path contents <- liftIO $ BSL8.readFile path
ST.put $ RequestBuilderData ((ReqFilePart name path contents mimetype):parts) r ST.put $ RequestBuilderData ((ReqFilePart name path contents mimetype):parts) r
-- This looks up the name of a field based on the contents of the label pointing to it. -- This looks up the name of a field based on the contents of the label pointing to it.
nameFromLabel :: String -> RequestBuilder String nameFromLabel :: T.Text -> RequestBuilder T.Text
nameFromLabel label = withResponse $ \ res -> do nameFromLabel label = withResponse $ \ res -> do
let let
body = simpleBody res body = simpleBody res
escaped = escapeHtmlEntities label escaped = escapeHtmlEntities label
mfor = parseHTML body $ deep $ hasName "label" mfor = parseHTML body $ \c -> c
>>> filterA (xshow this >>> mkText >>> hasText (DL.isInfixOf escaped)) $// attributeIs "name" "label"
>>> getAttrValue "for" >=> contentContains escaped
>=> attribute "for"
contentContains x c
| x `T.isInfixOf` T.concat (c $// content) = [c]
| otherwise = []
case mfor of case mfor of
for:[] -> do for:[] -> do
let mname = parseHTML body $ deep $ hasAttrValue "id" (==for) >>> getAttrValue "name" let mname = parseHTML body $ \c -> c
$// attributeIs "id" for
>=> attribute "name"
case mname of case mname of
"":_ -> failure $ "Label "++label++" resolved to id "++for++" which was not found. " "":_ -> failure $ T.concat
[ "Label "
, label
, " resolved to id "
, for
, " which was not found. "
]
name:_ -> return name name:_ -> return name
_ -> failure $ "More than one input with id " ++ for _ -> failure $ "More than one input with id " <> for
[] -> failure $ "No label contained: "++label [] -> failure $ "No label contained: " <> label
_ -> failure $ "More than one label contained "++label _ -> failure $ "More than one label contained " <> label
(<>) :: T.Text -> T.Text -> T.Text
(<>) = T.append
-- | Escape HTML entities in a string, so you can write the text you want in -- | Escape HTML entities in a string, so you can write the text you want in
-- label lookups without worrying about the fact that yesod escapes some characters. -- label lookups without worrying about the fact that yesod escapes some characters.
escapeHtmlEntities :: String -> String escapeHtmlEntities :: T.Text -> T.Text
escapeHtmlEntities "" = "" escapeHtmlEntities =
escapeHtmlEntities (c:cs) = case c of T.concatMap go
'<' -> '&' : 'l' : 't' : ';' : escapeHtmlEntities cs where
'>' -> '&' : 'g' : 't' : ';' : escapeHtmlEntities cs go '<' = "&lt;"
'&' -> '&' : 'a' : 'm' : 'p' : ';' : escapeHtmlEntities cs go '>' = "&gt;"
'"' -> '&' : 'q' : 'u' : 'o' : 't' : ';' : escapeHtmlEntities cs go '&' = "&amp;"
'\'' -> '&' : '#' : '3' : '9' : ';' : escapeHtmlEntities cs go '"' = "&quot;"
x -> x : escapeHtmlEntities cs go '\'' = "&#39;"
go x = T.singleton x
byLabel :: String -> String -> RequestBuilder () byLabel :: T.Text -> T.Text -> RequestBuilder ()
byLabel label value = do byLabel label value = do
name <- nameFromLabel label name <- nameFromLabel label
byName name value byName name value
fileByLabel :: String -> FilePath -> String -> RequestBuilder () fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder ()
fileByLabel label path mime = do fileByLabel label path mime = do
name <- nameFromLabel label name <- nameFromLabel label
fileByName name path mime fileByName name path mime
@ -328,7 +346,7 @@ addNonce_ scope = do
matches <- htmlQuery $ scope `mappend` "input[name=_token][type=hidden][value]" matches <- htmlQuery $ scope `mappend` "input[name=_token][type=hidden][value]"
case matches of case matches of
[] -> failure $ "No nonce found in the current page" [] -> failure $ "No nonce found in the current page"
element:[] -> byName "_token" $ head $ parseHTML element $ getAttrValue "value" element:[] -> byName "_token" $ head $ parseHTML element $ attribute "value"
_ -> failure $ "More than one nonce found in the page" _ -> failure $ "More than one nonce found in the page"
-- | For responses that display a single form, just lookup the only nonce available. -- | For responses that display a single form, just lookup the only nonce available.
@ -380,22 +398,22 @@ doRequest method url paramsBuild = do
BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts] BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts]
multipartPart (ReqPlainPart k v) = BS8.concat multipartPart (ReqPlainPart k v) = BS8.concat
[ "Content-Disposition: form-data; " [ "Content-Disposition: form-data; "
, "name=\"", (BS8.pack k), "\"\r\n\r\n" , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n"
, (BS8.pack v), "\r\n"] , TE.encodeUtf8 v, "\r\n"]
multipartPart (ReqFilePart k v bytes mime) = BS8.concat multipartPart (ReqFilePart k v bytes mime) = BS8.concat
[ "Content-Disposition: form-data; " [ "Content-Disposition: form-data; "
, "name=\"", BS8.pack k, "\"; " , "name=\"", TE.encodeUtf8 k, "\"; "
, "filename=\"", BS8.pack v, "\"\r\n" , "filename=\"", BS8.pack v, "\"\r\n"
, "Content-Type: ", BS8.pack mime, "\r\n\r\n" , "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n"
, BS8.concat $ BSL8.toChunks bytes, "\r\n"] , BS8.concat $ BSL8.toChunks bytes, "\r\n"]
-- For building the regular non-multipart requests -- For building the regular non-multipart requests
makeSinglepart cookie parts = SRequest (mkRequest makeSinglepart cookie parts = SRequest (mkRequest
[("Cookie",cookie), ("Content-Type", "application/x-www-form-urlencoded")]) $ [("Cookie",cookie), ("Content-Type", "application/x-www-form-urlencoded")]) $
BSL8.pack $ DL.concat $ DL.intersperse "&" $ map singlepartPart parts BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts
singlepartPart (ReqFilePart _ _ _ _) = "" singlepartPart (ReqFilePart _ _ _ _) = ""
singlepartPart (ReqPlainPart k v) = concat [k,"=",v] singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v]
-- General request making -- General request making
mkRequest headers = defaultRequest mkRequest headers = defaultRequest
@ -414,5 +432,5 @@ runDB query = do
liftIO $ runSqlPool query pool liftIO $ runSqlPool query pool
-- Yes, just a shortcut -- Yes, just a shortcut
failure :: (MonadIO a) => String -> a b failure :: (MonadIO a) => T.Text -> a b
failure reason = (liftIO $ HUnit.assertFailure reason) >> error "" failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""

1
yesod-test/yesod-test.cabal
View File

@ -15,7 +15,6 @@ extra-source-files: README.md, LICENSE, test/main.hs
library library
build-depends: base >= 4.3 && < 5 build-depends: base >= 4.3 && < 5
, hxt >= 9.1.6
, attoparsec >= 0.10 && < 0.11 , attoparsec >= 0.10 && < 0.11
, persistent >= 1.0 && < 1.1 , persistent >= 1.0 && < 1.1
, transformers >= 0.2.2 && < 0.4 , transformers >= 0.2.2 && < 0.4