wrecker 1.0.0.2 → 1.1.0.0
raw patch · 7 files changed
+186/−62 lines, 7 files
Files
- examples/Client.lhs +6/−8
- src/Network/Wreq/Wrecker.hs +73/−1
- src/Wrecker.hs +1/−0
- src/Wrecker/Recorder.hs +49/−34
- src/Wrecker/Runner.hs +17/−14
- src/Wrecker/Statistics.hs +39/−4
- wrecker.cabal +1/−1
examples/Client.lhs view
@@ -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) ``` ## <a name="Make_a_Somewhat_Generic_REST_API"> Make a Somewhat Generic REST API
src/Network/Wreq/Wrecker.hs view
@@ -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
src/Wrecker.hs view
@@ -19,6 +19,7 @@ , Environment(..) -- * Recorder , Recorder+ , LogicError(..) , record -- * Options , Options(..)
src/Wrecker/Recorder.hs view
@@ -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+ }
src/Wrecker/Runner.hs view
@@ -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
src/Wrecker/Statistics.hs view
@@ -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 ]
wrecker.cabal view
@@ -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