module Test.HTTP (httpTestCase, get, getJSON, withJSON, post, postJSON, postForm, assert, assertEq, assertParse, debug, Session, Url, Tasty.defaultMain, tic, toc) 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 Data.Time
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,
timer :: UTCTime }
type Url = String
httpTestCase :: String
-> Url
-> Session ()
-> TestTree
httpTestCase sessionName sessBaseURL m = HUnit.testCase sessionName $ do
tm <- getCurrentTime
S.evalStateT m $ HttpTest sessBaseURL (HT.createCookieJar []) tm
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 :: Url
-> Session String
get url = do
(code, res) <- getRaw url
when (code /= 200) $
assertFailure $ "GET "++url++": "++show code
return res
getRaw :: Url -> Session (Int, String)
getRaw url = withHT $ \(HttpTest base cj _) -> do
r <- Wreq.getWith (Wreq.defaults & Wreq.cookies .~ Just cj) (base ++ url)
return (r ^. Wreq.responseCookieJar,
(r ^. Wreq.responseStatus . Wreq.statusCode,
unpack $ r ^. Wreq.responseBody))
getJSON :: Ae.FromJSON a =>
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
withJSON :: Ae.FromJSON a =>
String
-> (a -> Session ())
-> 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 ()
postRaw :: WreqT.Postable a => Url -> a -> Session String
postRaw url body = withHT $ \(HttpTest base cj _) -> do
r <- Wreq.postWith (Wreq.defaults & Wreq.cookies .~ Just 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)
postForm :: Url
-> [(String,String)]
-> Session String
postForm url fields = postRaw url $ map (\(x,y) -> (BL.toStrict $ pack x, BL.toStrict $ pack y)) fields
post :: Url -> String -> Session String
post u s = postRaw u $ pack s
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
assert :: String
-> Bool
-> Session ()
assert assName True = liftIO $ putStrLn $ "Pass: "++assName
assert assName False = liftIO $ HUnit.assertFailure assName
assertFailure :: String -> Session ()
assertFailure nm = liftIO $ HUnit.assertFailure nm
assertEq :: (Show a, Eq a) => String
-> a
-> a
-> Session ()
assertEq assName x y | x == y = liftIO $ putStrLn $ "Pass: "++assName
| otherwise = liftIO $ HUnit.assertFailure $ assName++show x ++" /= "++show y
assertParse :: String
-> Parser Bool
-> 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"
debug :: String -> Session ()
debug s = liftIO $ putStrLn s
tic :: Session ()
tic = do
now <- liftIO $ getCurrentTime
S.modify $ \s -> s { timer = now }
toc :: String -> Session Double
toc s = do
last <- fmap timer $ S.get
now <- liftIO $ getCurrentTime
let df = diffUTCTime now last
liftIO $ putStrLn $ s ++ " "++show df
return $ realToFrac df