diff --git a/HttpTestExec.hs b/HttpTestExec.hs new file mode 100644 --- /dev/null +++ b/HttpTestExec.hs @@ -0,0 +1,22 @@ +import System.Environment +import qualified Network.Wreq +import qualified Network.Wreq +import Control.Lens +import Data.Aeson.Lens +import Control.Monad +import Network.URI +main = do + args <- getArgs + mapM_ dispatch $ filter notOption args + +dispatch file = case parseURI file of + Nothing -> runFile file + Just _ -> runHttp file + + + + +isOption ('-':_) = True +isOption _ = False + +notOption = not . isOption diff --git a/Test/HTTP.hs b/Test/HTTP.hs deleted file mode 100644 --- a/Test/HTTP.hs +++ /dev/null @@ -1,265 +0,0 @@ -module Test.HTTP (httpTest, session, get, getJSON, withJSON, post, postForm, postJSON, assert, assertEq, assertParse, failTest, debug, Program, Session, Url, curlGetString, curlPostString) where - -import Network.Curl hiding (curlGetString) - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception hiding (assert) -import Control.Monad -import Control.Monad.Error -import Control.Monad.Reader -import qualified Control.Monad.State.Strict as State -import Control.Monad.Trans -import Data.Char -import Data.IORef -import Data.List -import Data.Maybe -import GHC.Conc -import qualified Data.Aeson as Ae -import Data.Aeson.Types (Parser, parseEither) -import Safe (readMay) -import System.Environment -import System.Exit -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Data.ByteString.Lazy (fromStrict, toStrict) - - -type Program = ReaderT (TVar [Results]) IO - -data SessionState = SessionState { sessionResults :: Results, - sessionBaseUrl :: String, - sessionCurl :: Curl } - -type Session a = State.StateT SessionState (ErrorT String IO) a - -type Results = [(String, Maybe String)] - -type Url = String - --- | Run one or more test sessions. httpTest will exit when done, with --- exit code 1 if there were failures -httpTest :: Program () -> IO () -httpTest m = withCurlDo $ do - resTV <- newTVarIO [] - runReaderT m resTV - finalRes <- fmap concat $ readTVarIO resTV - - mapM_ (putStrLn . ppRes) finalRes - - if any (isJust . snd) finalRes - then exitWith $ ExitFailure 1 - else exitWith $ ExitSuccess - -ppRes (nm, Nothing) = "Pass: "++nm -ppRes (nm, Just reason) = "FAIL: "++nm++"; "++reason - - --- | Define a single test session based on session name and base url -session :: String -- ^ Session name (used for logging failures) - -> Url -- ^ Base URL - -> Session () -- ^ the actions and assertions that define the session - -> Program () -session sessionName baseURL m = do - c <- liftIO $ initialize - let state0 = SessionState [] baseURL c - liftIO $ setopts c [CurlCookieJar (sessionName++"_cookies"), - CurlFollowLocation True] - res <- liftIO $ runErrorT $ State.execStateT m state0 - case res of - Right (SessionState res _ _) -> do - res_tv <- ask - liftIO $ atomically $ do - others <- readTVar res_tv - writeTVar res_tv $ others ++ [reverse res] - Left err -> do - res_tv <- ask - liftIO $ atomically $ do - others <- readTVar res_tv - writeTVar res_tv $ others ++ - [[(sessionName, - Just $ sessionName ++ " session failure:" ++err)]] - --- | GET a web page as a String -get :: Url -- ^ URL - -> Session String -get url = do - (code, res) <- getRaw url - when (code /= CurlOK) $ - failTest ("GET "++url) (show code++"\nResponse:\n"++res) - return res - -getRaw :: Url -> Session (CurlCode, String) -getRaw url = do - SessionState _ base c <- State.get - liftIO $ curlGetString c (base++url) [] - --- | GET a JSON value -getJSON :: Ae.FromJSON a => - Url -- ^ URL - -> Session a -getJSON url = do - str <- get url - case Ae.eitherDecode' $ fromStrict $ encodeUtf8 $ T.pack str of - Right x -> return x - Left err -> throwError $ "GET "++url ++ " JSON decoding failure: "++ err - - --- | perform an action with a JSON value from a GET -withJSON :: Ae.FromJSON a => - String -- ^ URL - -> (a -> Session ()) -- ^ action to perform on successfully decoded value - -> Session () -withJSON url mu = do - str <- get url - case Ae.eitherDecode' $ fromStrict $ encodeUtf8 $ T.pack str of - Right x -> mu x - Left err -> do failTest ("GET "++url) $ "JSON decoding failure: "++ err - return () - --- | Post a form -postForm :: Url -- ^ URL - -> [(String,String)] -- ^ form fields - -> Session String -postForm url fields = post url $ map (\(x,y) -> x ++ ('=':y)) fields - --- | Post a string body -post :: Url -> [String] -> Session String -post url body = do - SessionState _ base c <- State.get - (code, res) <- liftIO $ curlPostString c (base++url) [] body - when (code /= CurlOK) $ - failTest ("POST "++url) (show code++"\nResponse:\n"++res) - return res - --- | Post a JSON value -postJSON :: (Ae.ToJSON a, Ae.FromJSON b) => Url -> a -> Session b -postJSON url x = do str <- post url [T.unpack $ decodeUtf8 $ toStrict $ Ae.encode x] - case Ae.eitherDecode' $ fromStrict $ encodeUtf8 $ T.pack str of - Right x -> return x - Left err -> throwError $ "POST "++url ++ " JSON decoding failure: "++ err - - - - --- | make an assertion -assert :: String -- ^ assertion name (used for reporting failures - -> Bool -- ^ Boolean of which we are asserting truth - -> Session () -assert assName True = passTest assName -assert assName False = failTest assName "fail" - --- | assert equality, for better output messages -assertEq :: (Show a, Eq a) => String -- ^ assertion name (used for reporting failures - -> a -- ^ a value - -> a -- ^ what it is meant to be equal to - -> Session () -assertEq assName x y | x == y = passTest assName - | otherwise = failTest assName $ "not equal: "++show x ++" /= "++show y - --- | make an assertion in the Parser monad, for use with JSON value -assertParse :: String -- ^ assertion name (used for reporting failures - -> Parser Bool -- ^ Boolean of which we are asserting truth - -> Session () -assertParse assName pb = - case parseEither (const pb) () of - Left err -> failTest assName $ "parse failure: "++err - Right True -> passTest assName - Right False -> failTest assName "fail" - - --- | Output a string to stdout if @--verbose@ is in command line arguments -debug :: String -> Session () -debug s = do - args <- liftIO $ getArgs - if "--verbose" `elem` args - then liftIO $ putStrLn s - else return () - - - -addTestResult p = - State.modify $ \s -> s { sessionResults = p : sessionResults s } - -passTest tstNm = addTestResult (tstNm, Nothing) -failTest tstNm reason = addTestResult (tstNm, Just reason) - - -{------------------------------------------------------- - CURL AUXILIARY FUNCTIONS - -------------------------------------------------------} - --- | Custom version of getString that uses an existing Curl to handle cookies -curlGetString :: Curl -> URLString - -> [CurlOption] - -> IO (CurlCode, String) -curlGetString h url opts = do - ref <- newIORef [] - -- Note: later options may (and should, probably) override these defaults. - setopt h (CurlPostFields []) - setopt h (CurlPost False) - setopt h (CurlFailOnError True) - setDefaultSSLOpts h url - setopt h (CurlURL url) - setopt h (CurlWriteFunction (gatherOutput ref)) - mapM_ (setopt h) opts - rc <- perform h - lss <- readIORef ref - return (rc, concat $ reverse lss) - --- | Custom version of curlPost that uses an existing Curl to handle cookies --- and returns the result in a string. -curlPostString :: Curl -> URLString -> [CurlOption] -> [String] -> IO (CurlCode, String) -curlPostString h url opts body = do - ref <- newIORef [] - -- Note: later options may (and should, probably) override these defaults. - setopt h (CurlFollowLocation True) - setopt h (CurlFailOnError True) - setopt h (CurlPost True) - setopt h (CurlPostFields body) - setDefaultSSLOpts h url - setopt h (CurlURL url) - setopt h (CurlWriteFunction (gatherOutput ref)) - mapM_ (setopt h) opts - rc <- perform h - lss <- readIORef ref - return (rc, concat $ reverse lss) - -{------------------------------------------------------- - ENCODING - -------------------------------------------------------} --- | FIXME (iperez): I don't know how to obtain all the possible --- transformations that can occur in the output. This should contain all HTML --- and Unicode representations that can be used by the server but were not in --- the original file. -decode :: String -> String -decode [] = [] -decode ('\\':'u':a:b:c:d:xs) - | isHexDigit a && isHexDigit b && isHexDigit c && isHexDigit d - = chr (hexToInt [a,b,c,d]) : decode xs -decode ('\\':'n': xs) = '\n' : decode xs -decode ('\\':'"': xs) = '"' : decode xs -decode ('&':'q':'u':'o':'t':';':xs) = '"' : decode xs -decode ('&':'g':'t':';':xs) = '>' : decode xs -decode ('&':'l':'t':';':xs) = '<' : decode xs -decode (x : xs) = x : decode xs - -hexToInt :: String -> Int -hexToInt [] = 0 -hexToInt [n] = digitToInt n -hexToInt (n:ns) = digitToInt n * 16 + hexToInt ns - -{------------------------------------------------------- - CONCURRENCY AUX - -------------------------------------------------------} - --- | fork a thread and call the supplied function when the thread is about to --- terminate, with an exception or a returned value. The function is called --- with asynchronous exceptions masked. --- NOTE: This is taken from Control.Concurrency because it's not present in --- GHC 7.4 -{-forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId -forkFinally action and_then = - mask $ \restore -> - forkIO $ Control.Exception.try (restore action) >>= and_then --} diff --git a/http-test.cabal b/http-test.cabal --- a/http-test.cabal +++ b/http-test.cabal @@ -1,5 +1,5 @@ Name: http-test -Version: 0.1.7 +Version: 0.2 synopsis: Test framework for HTTP APIs Description: A simple framework for making assertions about the responses of HTTP servers. @@ -7,8 +7,7 @@ > import Test.HTTP > import Data.List (isInfixOf) > - > main = httpTest $ do - > session "BayesHive landing page" "https://bayeshive.com" $ do + > main = defaultMain $ httpTestCase "BayesHive landing page" "https://bayeshive.com" $ do > landing <- get "/" > assert "Correct blog link" $ > "href=\"https://bayeshive.com/blog\"" `isInfixOf` landing @@ -33,23 +32,32 @@ Library Exposed-modules: Test.HTTP + hs-source-dirs: src Build-depends: base >= 4 && < 5 - , mtl >= 2.1 && < 2.2 - , curl >= 1.3.8 && < 2 - , aeson >= 0.6 && < 0.8 - , safe >= 0.2 && < 0.4 - , stm >= 2.4 && < 2.5 - , text >= 0.10 && < 1.2 + , mtl + , aeson >= 0.7 && < 0.8 + , wreq + , tasty + , tasty-hunit + , text >= 1.1 && < 1.2 , bytestring + , lens + , http-client -executable test-http-test +executable test-http-test-on-bayeshive main-is: test.hs Build-depends: base >= 4 && < 5 - , mtl >= 2.1 && < 2.2 - , curl >= 1.3.8 && < 2 - , aeson - , safe >= 0.2 && < 0.4 - , stm >= 2.4 && < 2.5 - , text - , bytestring , http-test + +executable http-test + main-is: HttpTestExec.hs + Buildable: False + Build-depends: base >= 4 && < 5 + , lens + , http-client + , mtl + , aeson >= 0.7 && < 0.8 + , wreq + , text >= 1.1 && < 1.2 + , bytestring + , network diff --git a/src/Test/HTTP.hs b/src/Test/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Test/HTTP.hs @@ -0,0 +1,170 @@ +module Test.HTTP (httpTestCase, get, getJSON, withJSON, post, postJSON, postForm, assert, assertEq, assertParse, debug, Session, Url, Tasty.defaultMain) where + +import Control.Monad +import Control.Monad.Error +import qualified Control.Monad.State.Strict as S +import Control.Monad.Trans +import Data.Char +import Data.IORef +import Data.List +import Data.Maybe +import qualified Data.Aeson as Ae +import Data.Aeson.Types (Parser, parseEither) +import System.Environment +import System.Exit +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import qualified Data.ByteString.Lazy as BL + +import qualified Test.Tasty.HUnit as HUnit +import Test.Tasty as Tasty +import qualified Network.Wreq as Wreq +import qualified Network.Wreq.Types as WreqT +import Control.Lens +import Data.Aeson.Lens + +import qualified Network.HTTP.Client as HT + +import Data.ByteString.Lazy.Char8 (unpack, pack) + +type Session = S.StateT HttpTest IO + +data HttpTest = HttpTest { baseUrl :: String, + cookieJar :: HT.CookieJar } + +type Url = String + + +httpTestCase :: String -- ^ Session name (used for logging failures) + -> Url -- ^ Base URL + -> Session () -- ^ the actions and assertions that define the session + -> TestTree +httpTestCase sessionName sessBaseURL m = HUnit.testCase sessionName $ do + S.evalStateT m $ HttpTest sessBaseURL (HT.createCookieJar []) + + +withHT :: (HttpTest -> IO (HT.CookieJar, a)) -> Session a +withHT m = do + ht <- S.get + (cj, x) <- liftIO $ m ht + S.modify $ \ht -> ht { cookieJar = cj } + return x + +-- | GET a web page as a String +get :: Url -- ^ URL + -> Session String +get url = do + (code, res) <- getRaw url + when (code /= 200) $ + assertFailure $ "GET "++url++": "++show code -- ++"\nResponse:\n"++res + return res + + + +getRaw :: Url -> Session (Int, String) +getRaw url = withHT $ \(HttpTest base cj) -> do + r <- Wreq.getWith (Wreq.defaults & Wreq.cookies .~ cj) (base ++ url) + return (r ^. Wreq.responseCookieJar, + (r ^. Wreq.responseStatus . Wreq.statusCode, + unpack $ r ^. Wreq.responseBody)) + + +-- | GET a JSON value +getJSON :: Ae.FromJSON a => + Url -- ^ URL + -> Session a +getJSON url = do + str <- get url + case Ae.eitherDecode' $ BL.fromStrict $ encodeUtf8 $ T.pack str of + Right x -> return x + Left err -> throwError $ strMsg $ "GET "++url ++ " JSON decoding failure: "++ err + + +-- | perform an action with a JSON value from a GET +withJSON :: Ae.FromJSON a => + String -- ^ URL + -> (a -> Session ()) -- ^ action to perform on successfully decoded value + -> Session () +withJSON url mu = do + str <- get url + case Ae.eitherDecode' $ BL.fromStrict $ encodeUtf8 $ T.pack str of + Right x -> mu x + Left err -> do assertFailure $ "GET "++url++"JSON decoding failure: "++ err + return () + + +-- | Post a string body +postRaw :: WreqT.Postable a => Url -> a -> Session String +postRaw url body = withHT $ \(HttpTest base cj) -> do + r <- Wreq.postWith (Wreq.defaults & Wreq.cookies .~ cj) (base ++ url) body + + let code = r ^. Wreq.responseStatus . Wreq.statusCode + + when (code /= 200) $ + liftIO $ HUnit.assertFailure $ "POST "++url++": "++show code++"\nResponse:\n"++show r + return $ (r ^. Wreq.responseCookieJar, unpack $ r ^. Wreq.responseBody) + + + + +-- | Post a form +postForm :: Url -- ^ URL + -> [(String,String)] -- ^ form fields + -> Session String +postForm url fields = postRaw url $ map (\(x,y) -> (BL.toStrict $ pack x, BL.toStrict $ pack y)) fields + + +-- | Post a string body +post :: Url -> String -> Session String +post u s = postRaw u $ pack s + + +-- | Post a JSON value +postJSON :: (Ae.ToJSON a, Ae.FromJSON b) => Url -> a -> Session b +postJSON url x = do str <- post url $ T.unpack $ decodeUtf8 $ BL.toStrict $ Ae.encode x + case Ae.eitherDecode' $ BL.fromStrict $ encodeUtf8 $ T.pack str of + Right x -> return x + Left err -> throwError $ strMsg $ "POST "++url ++ " JSON decoding failure: "++ err + + +-- | make an assertion +assert :: String -- ^ assertion name (used for reporting failures + -> Bool -- ^ Boolean of which we are asserting truth + -> Session () +assert assName True = liftIO $ putStrLn $ "Pass: "++assName +assert assName False = liftIO $ HUnit.assertFailure assName + +-- | assert an filure +assertFailure :: String -> Session () +assertFailure nm = liftIO $ HUnit.assertFailure nm + + +-- | assert equality, for better output messages +assertEq :: (Show a, Eq a) => String -- ^ assertion name (used for reporting failures + -> a -- ^ a value + -> a -- ^ what it is meant to be equal to + -> Session () +assertEq assName x y | x == y = liftIO $ putStrLn $ "Pass: "++assName + | otherwise = liftIO $ HUnit.assertFailure $ assName++show x ++" /= "++show y + +-- | make an assertion in the Parser monad, for use with JSON value +assertParse :: String -- ^ assertion name (used for reporting failures + -> Parser Bool -- ^ Boolean of which we are asserting truth + -> Session () +assertParse assName pb = + case parseEither (const pb) () of + Left err -> assertFailure $ assName++" parse failure: "++err + Right True -> liftIO $ putStrLn $ "Pass: "++assName + Right False -> assertFailure $ assName++" JSON assertion false" + + +-- | Output a string to stdout if @--verbose@ is in command line arguments +debug :: String -> Session () +debug s = liftIO $ putStrLn s + +{- args <- liftIO $ getArgs + if "--verbose" `elem` args + then + else return () -} + + diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -1,11 +1,12 @@ import Test.HTTP import Data.List (isInfixOf) -main = httpTest $ do - session "BayesHive landing page" "https://bayeshive.com" $ do +main = defaultMain $ httpTestCase "BayesHive landing page" "https://bayeshive.com" $ do landing <- get "/" assert "Correct blog link" $ "href=\"https://bayeshive.com/blog\"" `isInfixOf` landing loginResult <- postForm "/auth/page/email/login" - [("email", "foo"), ("password", "bar")] - debug loginResult + [("email", "footest@bar.com"), ("password", "secret")] + doclist <- getJSON "/doclist" + debug $ show (doclist:: [String]) + return ()