diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +The MIT License (MIT) + +Copyright (c) 2013 Tom Nielsen + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/Test/HTTP.hs b/Test/HTTP.hs new file mode 100644 --- /dev/null +++ b/Test/HTTP.hs @@ -0,0 +1,207 @@ +module Test.HTTP (httpTest, session, get, getJSON, postForm, assert, Program, Session) 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 Safe (readMay) +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import System.IO.Error +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.ByteString.Lazy (fromStrict) + + +type Program = ReaderT (TVar [Results]) IO + +data SessionState = SessionState { sessionResults :: Results, + sessionBaseUrl :: String, + sessionCurl :: Curl } + +--what we really want +--type Session = EitherT String (State.StateT SessionState IO) + +type Session = State.StateT SessionState IO + +type Results = [(String, Maybe 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) + -> String -- ^ 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] + SessionState res _ _ <- liftIO $ State.execStateT m state0 + res_tv <- ask + liftIO $ atomically $ do + others <- readTVar res_tv + writeTVar res_tv $ others ++ [res] + +-- | GET a web page as a String +get :: String -- ^ URL + -> Session String +get url = do + (code, res) <- getRaw url + when (code /= CurlOK) $ + failTest ("GET "++url) (show code) + return res + +getRaw :: String -> Session (CurlCode, String) +getRaw url = do + SessionState _ base c <- State.get + liftIO $ curlGetString c (base++url) [] + +-- | GET a JSON value +getJSON :: Ae.FromJSON a => + String -- ^ URL + -> Session a +getJSON url = do + str <- get url + let Just x = Ae.decode' $ fromStrict $ encodeUtf8 $ T.pack str + return x + +-- | POST a form +postForm :: String -- ^ URL + -> [(String,String)] -- ^ form fields + -> Session String +postForm url fields = do + SessionState _ base c <- State.get + (code, res) <- liftIO $ curlPostString c (base++url) [] fields + when (code /= CurlOK) $ + failTest ("POST "++url) (show code) + return res + +-- | 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" + +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, String)] -> IO (CurlCode, String) +curlPostString h url opts fields = 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 fields') + 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) + where fields' = map (\(x,y) -> x ++ '=':y) fields + +{------------------------------------------------------- + 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 new file mode 100644 --- /dev/null +++ b/http-test.cabal @@ -0,0 +1,42 @@ +Name: http-test +Version: 0.1.1 +synopsis: Test framework for HTTP APIs +Description: A simple framework for making assertions about the + responses of HTTP servers. See test.hs for an example +License: BSD3 +Author: OpenBrain Ltd +Maintainer: tomn@openbrain.org +build-type: Simple +Cabal-Version: >= 1.8 +homepage: https://github.com/openbrainsrc/http-test +bug-reports: https://github.com/openbrainsrc/http-test/issues +Category: Test, Web +license-file: LICENSE + +Source-Repository head + Type: git + Location: https://github.com/openbrainsrc/http-test + + +Library + Exposed-modules: Test.HTTP + 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 + , bytestring + +executable test-http-test + 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 diff --git a/test.hs b/test.hs new file mode 100644 --- /dev/null +++ b/test.hs @@ -0,0 +1,14 @@ +module Main where + +import Test.HTTP +import Data.List +import Control.Monad.Trans + +main = httpTest $ do + session "BayesHive landing page" "https://bayeshive.com" $ do + landing <- get "/" + assert "Correct blog link" $ + "href=\"https://bayeshive.com/blog\"" `isInfixOf` landing + postForm "/auth/page/email/login" + [("email", "foo"), ("password", "bar")] + return ()