diff --git a/examples/Client.lhs b/examples/Client.lhs --- a/examples/Client.lhs +++ b/examples/Client.lhs @@ -86,7 +86,6 @@ ```haskell import Network.Wreq (Response) -import qualified Network.Wreq as Wreq import Network.Wreq.Wrecker (Session) import qualified Network.Wreq.Wrecker as WW ``` @@ -97,7 +96,6 @@ #### Other packages you can mostly ignore ```haskell import GHC.Generics -import Data.ByteString.Lazy (ByteString) import Data.Text as T import Network.HTTP.Client (responseBody) ``` @@ -136,16 +134,16 @@ - We unwrap values coming from the server in `Envelope`. ```haskell - fromEnvelope :: FromJSON a => IO (Response ByteString) -> IO a - fromEnvelope x = fmap (value . responseBody) . Wreq.asJSON =<< x + fromEnvelope :: FromJSON a => IO (Response (Envelope a)) -> IO a + fromEnvelope x = fmap (value . responseBody) x ``` - We wrap inputs and unwrap outputs so we can wrap a whole function. ```haskell liftEnvelope :: (ToJSON a, FromJSON b) - => (Value -> IO (Response ByteString)) - -> (a -> IO b ) + => (Value -> IO (Response (Envelope b))) + -> (a -> IO b) liftEnvelope f = fromEnvelope . f . toEnvelope ``` @@ -155,10 +153,10 @@ ```haskell jsonGet :: FromJSON a => Session -> Text -> IO a -jsonGet sess url = fromEnvelope $ WW.get sess (T.unpack url) +jsonGet sess url = fromEnvelope $ WW.getJSON sess (T.unpack url) jsonPost :: (ToJSON a, FromJSON b) => Session -> Text -> a -> IO b -jsonPost sess url = liftEnvelope $ WW.post sess (T.unpack url) +jsonPost sess url = liftEnvelope $ WW.postJSON sess (T.unpack url) ``` ## Make a Somewhat Generic REST API diff --git a/src/Network/Wreq/Wrecker.hs b/src/Network/Wreq/Wrecker.hs --- a/src/Network/Wreq/Wrecker.hs +++ b/src/Network/Wreq/Wrecker.hs @@ -6,7 +6,7 @@ -} -- All of this code below was copied from bos's `Network.Wreq.Session` -- and modified to include the wrecker recorder -{-# LANGUAGE CPP, RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module Network.Wreq.Wrecker ( Session @@ -29,13 +29,25 @@ , optionsWith , putWith , deleteWith + -- * HTTP Methods to get JSON responses + , getJSON + , getJSONWith + , postJSON + , postJSONWith + , putJSON + , putJSONWith + , deleteJSON + , deleteJSONWith ) where +import Control.Exception (fromException, handle, throwIO) +import Data.Aeson (FromJSON) import qualified Data.ByteString.Lazy as L import Data.Default (def) import Network.Connection (ConnectionContext) import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as TLS +import qualified Network.Wreq as Wreq import qualified Network.Wreq.Session as Session import qualified Network.Wreq.Types as Wreq import Wrecker @@ -148,3 +160,63 @@ -- | 'Session'-specific version of 'Network.Wreq.deleteWith'. deleteWith :: Wreq.Options -> Session -> String -> IO (HTTP.Response L.ByteString) deleteWith opts = withSess (Session.deleteWith opts) + +-- | 'Session'-specific version of 'Network.Wreq.get' that expects a JSON response. +getJSON :: FromJSON a => Session -> String -> IO (HTTP.Response a) +getJSON = withSess (\sess url -> Session.get sess url >>= fromJSON "GET" url) + +-- | 'Session'-specific version of 'Network.Wreq.post' that expects a JSON response. +postJSON :: (Wreq.Postable a, FromJSON b) => Session -> String -> a -> IO (HTTP.Response b) +postJSON = withSess1 (\sess url body -> Session.post sess url body >>= fromJSON "POST" url) + +-- | 'Session'-specific version of 'Network.Wreq.put' that expects a JSON response. +putJSON :: (Wreq.Putable a, FromJSON b) => Session -> String -> a -> IO (HTTP.Response b) +putJSON = withSess1 (\sess url body -> Session.put sess url body >>= fromJSON "PUT" url) + +-- | 'Session'-specific version of 'Network.Wreq.delete' that expects a JSON response. +deleteJSON :: FromJSON a => Session -> String -> IO (HTTP.Response a) +deleteJSON = withSess (\sess url -> Session.delete sess url >>= fromJSON "DELETE" url) + +-- | 'Session'-specific version of 'Network.Wreq.getWith' that expects a JSON response. +getJSONWith :: FromJSON a => Wreq.Options -> Session -> String -> IO (HTTP.Response a) +getJSONWith opts = withSess (\sess url -> Session.getWith opts sess url >>= fromJSON "GET" url) + +-- | 'Session'-specific version of 'Network.Wreq.postWith' that expects a JSON response. +postJSONWith :: + (Wreq.Postable a, FromJSON b) + => Wreq.Options + -> Session + -> String + -> a + -> IO (HTTP.Response b) +postJSONWith opts = + withSess1 (\sess url body -> Session.postWith opts sess url body >>= fromJSON "POST" url) + +-- | 'Session'-specific version of 'Network.Wreq.putWith' that expects a JSON response. +putJSONWith :: + (Wreq.Putable a, FromJSON b) + => Wreq.Options + -> Session + -> String + -> a + -> IO (HTTP.Response b) +putJSONWith opts = + withSess1 (\sess url body -> Session.putWith opts sess url body >>= fromJSON "PUT" url) + +-- | 'Session'-specific version of 'Network.Wreq.deleteWith' that expects a JSON response. +deleteJSONWith :: FromJSON a => Wreq.Options -> Session -> String -> IO (HTTP.Response a) +deleteJSONWith opts = + withSess (\sess url -> Session.deleteWith opts sess url >>= fromJSON "DELETE" url) + +-- | Helper function used to create better error messages when failing to decode JSON responses +fromJSON :: FromJSON a => String -> String -> HTTP.Response L.ByteString -> IO (HTTP.Response a) +fromJSON verb url response = handle decorateEx (Wreq.asJSON response) + where + decorateEx ex = + case fromException ex of + Just (Wreq.JSONError err) -> + throwIO + (LogicError + ("Error decoding the JSON response from " ++ + verb ++ " " ++ url ++ " : " ++ err)) + _ -> throwIO ex diff --git a/src/Wrecker.hs b/src/Wrecker.hs --- a/src/Wrecker.hs +++ b/src/Wrecker.hs @@ -19,6 +19,7 @@ , Environment(..) -- * Recorder , Recorder + , LogicError(..) , record -- * Options , Options(..) diff --git a/src/Wrecker/Recorder.hs b/src/Wrecker/Recorder.hs --- a/src/Wrecker/Recorder.hs +++ b/src/Wrecker/Recorder.hs @@ -21,6 +21,7 @@ | Error { resultTime :: !Double , exception :: !SomeException , name :: !String } + | RuntimeError | End deriving (Show) @@ -38,6 +39,20 @@ , rQueue :: !(TBMQueue Event) } +newtype LogicError = + LogicError String + +instance Show LogicError where + show (LogicError err) = err + +instance Exception LogicError + +newtype HandledError = + HandledError SomeException + deriving (Show) + +instance Exception HandledError + -- The bound here should be configurable split :: Recorder -> Recorder split Recorder {..} = Recorder rWithQuery (rRunIndex + 1) rQueue @@ -66,37 +81,37 @@ -} record :: forall a. Recorder -> String -> IO a -> IO a record recorder key action = do - let cleanKey = - if rWithQuery recorder - then key - else takeWhile (/= '?') key -- Remove the query string - startTime <- getTime Monotonic - let recordAction :: IO a - recordAction = do - r <- action - endTime <- getTime Monotonic - let !elapsedTime' = diffSeconds endTime startTime - addEvent recorder $ Success {resultTime = elapsedTime', name = cleanKey} - return r - recordException :: HTTP.HttpException -> IO a - recordException e = do - endTime <- getTime Monotonic - case e of - HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException resp _) -> do - let code = HTTP.statusCode $ HTTP.responseStatus resp - addEvent recorder $ - ErrorStatus - { resultTime = diffSeconds endTime startTime - , errorCode = code - , name = cleanKey - } - _ -> - addEvent recorder $ - Error - { resultTime = diffSeconds endTime startTime - , exception = toException e - , name = cleanKey - } - -- rethrow no matter what - throwIO e - handle recordException recordAction + !startTime <- getTime Monotonic + handle (recordException startTime) (recordAction startTime) + where + cleanKey = + if rWithQuery recorder + then key + else takeWhile (/= '?') key -- Remove the query string + recordAction :: TimeSpec -> IO a + recordAction startTime = do + r <- action + endTime <- getTime Monotonic + let !elapsedTime' = diffSeconds endTime startTime + addEvent recorder $ Success {resultTime = elapsedTime', name = cleanKey} + return r + recordException :: TimeSpec -> SomeException -> IO a + recordException startTime ex = do + endTime <- getTime Monotonic + handleException endTime ex + throwIO (HandledError ex) + where + handleException endTime e + | Just ((HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException resp _))) <- + fromException e = do + let code = HTTP.statusCode $ HTTP.responseStatus resp + addEvent recorder $ + ErrorStatus + {resultTime = diffSeconds endTime startTime, errorCode = code, name = cleanKey} + | otherwise = + addEvent recorder $ + Error + { resultTime = diffSeconds endTime startTime + , exception = toException e + , name = cleanKey + } diff --git a/src/Wrecker/Runner.hs b/src/Wrecker/Runner.hs --- a/src/Wrecker/Runner.hs +++ b/src/Wrecker/Runner.hs @@ -25,14 +25,14 @@ import qualified Graphics.Vty as VTY import Network.Connection (ConnectionContext) import qualified Network.Connection as Connection -import qualified Network.HTTP.Client as HTTP import System.Exit import System.IO import System.Posix.Signals import System.Timeout import Wrecker.Logger import Wrecker.Options -import Wrecker.Recorder +import qualified Wrecker.Recorder as Recorder +import Wrecker.Recorder (Event(..), Recorder) import Wrecker.Statistics -- TODO configure whether errors are used in times or not @@ -54,7 +54,7 @@ -} newStandaloneRecorder :: IO (NextRef AllStats, Immortal.Thread, Recorder) newStandaloneRecorder = do - recorder <- newRecorder True 10000 + recorder <- Recorder.newRecorder True 10000 logger <- newStdErrLogger 1000 LevelError (ref, thread) <- sinkRecorder logger recorder return (ref, thread, recorder) @@ -68,13 +68,13 @@ updateSampler :: NextRef AllStats -> Event -> IO AllStats updateSampler !ref !event = modifyNextRef ref $ \x -> - let !new = stepAllStats x (eRunIndex event) (name $ eResult event) (eResult event) + let !new = stepAllStats x (eRunIndex event) (Recorder.name $ eResult event) (eResult event) in (new, new) collectEvent :: Logger -> NextRef AllStats -> Recorder -> IO () collectEvent logger ref recorder = fix $ \next -> do - mevent <- readEvent recorder + mevent <- Recorder.readEvent recorder for_ mevent $ \event -> do sampler <- updateSampler ref event logDebug logger $ show sampler @@ -84,22 +84,21 @@ runAction logger timeoutTime concurrency runStyle action env = do threadLimit <- BoundedThreadGroup.new concurrency recorderRef <- newIORef $ recorder env - let takeRecorder = atomicModifyIORef' recorderRef $ \x -> (split x, x) + let takeRecorder = atomicModifyIORef' recorderRef $ \x -> (Recorder.split x, x) actionThread = void $ BoundedThreadGroup.forkIO threadLimit $ do rec <- takeRecorder handle - (\(e :: SomeException) -> do + (\e -> do case fromException e of - Just (he :: HTTP.HttpException) -> void $ logWarn logger $ show he + Just (Recorder.HandledError he) -> void $ logWarn logger $ show he Nothing -> do logWarn logger $ show e - addEvent (recorder env) $ - Error {resultTime = 0, exception = e, name = "__UNKNOWN__"} - addEvent rec End) $ do + Recorder.addEvent (recorder env) Recorder.RuntimeError + Recorder.addEvent (recorder env) Recorder.End) $ do action (env {recorder = rec}) - addEvent rec End + Recorder.addEvent rec Recorder.End case runStyle of RunCount count -> replicateM_ (count * concurrency) actionThread RunTimed time -> void $ timeout (time * 1000000) $ forever actionThread @@ -113,12 +112,16 @@ ------------------------------------------------------------------------------- runWithNextVar :: Options + -- ^ The run options as passed from the CLI -> (NextRef AllStats -> IO ()) + -- ^ The statistics consumer action. Use this for example to present a summary of the stast -> (NextRef AllStats -> IO ()) + -- ^ The final consumer action. Maybe to present a final chart of the stats. -> (Environment -> IO ()) + -- ^ The load test action -> IO AllStats runWithNextVar (Options {..}) consumer final action = do - recorder <- newRecorder recordQuery 100000 + recorder <- Recorder.newRecorder recordQuery 100000 context <- Connection.initConnectionContext sampler <- newNextRef emptyAllStats logger <- newStdErrLogger 100000 logLevel @@ -131,7 +134,7 @@ let env = Environment {..} runAction logger timeoutTime concurrency runStyle action env `finally` (do logDebug logger "Shutting Down" - stopRecorder recorder + Recorder.stopRecorder recorder shutdownLogger 1000000 logger final sampler) readLast sampler diff --git a/src/Wrecker/Statistics.hs b/src/Wrecker/Statistics.hs --- a/src/Wrecker/Statistics.hs +++ b/src/Wrecker/Statistics.hs @@ -80,6 +80,8 @@ , rs5xx :: !Statistics , rsFailed :: !Statistics , rsRollup :: !Statistics + , rsTotalTests :: !Int + , rsTestsFailed :: !Int } deriving (Show) emptyResultStatistics :: ResultStatistics @@ -90,6 +92,8 @@ , rs5xx = emptyStatistics , rsFailed = emptyStatistics , rsRollup = emptyStatistics + , rsTotalTests = 0 + , rsTestsFailed = 0 } stepResultStatistics :: ResultStatistics -> RunResult -> ResultStatistics @@ -105,18 +109,22 @@ stats { rs4xx = stepStatistics (rs4xx stats) resultTime , rsRollup = stepStatistics (rsRollup stats) resultTime + , rsTestsFailed = rsTestsFailed stats + 1 } | otherwise -> stats { rs5xx = stepStatistics (rs5xx stats) resultTime , rsRollup = stepStatistics (rsRollup stats) resultTime + , rsTestsFailed = rsTestsFailed stats + 1 } Error {resultTime} -> stats { rsFailed = stepStatistics (rsFailed stats) resultTime , rsRollup = stepStatistics (rsRollup stats) resultTime + , rsTestsFailed = rsTestsFailed stats + 1 } - End -> stats + RuntimeError -> stats {rsTestsFailed = rsTestsFailed stats + 1} + End -> stats {rsTotalTests = rsTotalTests stats + 1} count2xx :: ResultStatistics -> Int count2xx = statsCount . rs2xx @@ -171,7 +179,7 @@ in case mRunStats of Nothing -> allStats Just stats - | errorRate stats == 0 -> + | rsTestsFailed stats == 0 && errorRate stats == 0 -> let runTime = sTotal $ rs2xx stats in allStats { aCompleteRuns = @@ -179,8 +187,23 @@ (aCompleteRuns allStats) (Success runTime "") , aRuns = H.delete index $ aRuns allStats + , aRollup = stepResultStatistics (aRollup allStats) result } - | otherwise -> allStats {aRuns = H.delete index $ aRuns allStats} + | otherwise -> + allStats + { aRollup = stepResultStatistics (aRollup allStats) result + , aRuns = H.delete index $ aRuns allStats + } + RuntimeError -> + allStats + { aRollup = stepResultStatistics (aRollup allStats) result + , aRuns = + H.insertWith + (\_ x -> stepResultStatistics x result) + index + (stepResultStatistics emptyResultStatistics result) $ + aRuns allStats + } _ -> allStats { aRollup = stepResultStatistics (aRollup allStats) result @@ -224,8 +247,18 @@ else printf "%.4f" n pprStats :: Maybe Int -> URLDisplay -> AllStats -> String -pprStats nameSize urlDisplay stats = AsciiArt.render id id id $ statsTable nameSize urlDisplay stats +pprStats nameSize urlDisplay stats = + let totals = AsciiArt.render id id id $ totalsTable stats + urlsTable = AsciiArt.render id id id $ statsTable nameSize urlDisplay stats + in urlsTable ++ "\n\n" ++ totals +totalsTable :: AllStats -> Table String String String +totalsTable AllStats {..} = + Table + (Group NoLine [Header "Test Runs"]) + (Group SingleLine [Header "Total", Header "Failed"]) + [[show $ rsTotalTests aRollup, show $ rsTestsFailed aRollup]] + adjustKey :: Maybe Int -> URLDisplay -> String -> String adjustKey keySize urlDisplay key = maybe id take keySize $ @@ -299,4 +332,6 @@ Object (H.fromList $ map (\(k, v) -> (T.pack k, toJSON v)) $ H.toList aPerUrl) , "runs" .= aCompleteRuns , "rollup" .= aRollup + , "totalRuns" .= rsTotalTests aRollup + , "totalFailures" .= rsTestsFailed aRollup ] diff --git a/wrecker.cabal b/wrecker.cabal --- a/wrecker.cabal +++ b/wrecker.cabal @@ -1,5 +1,5 @@ name: wrecker -version: 1.0.0.2 +version: 1.1.0.0 synopsis: An HTTP Performance Benchmarker description: 'wrecker' is a library and executable for creating HTTP benchmarks. It is designed for