Commits

Bryan O'Sullivan committed ffddca3

Record more analysis information.

* Some details of the environment in which the client runs.

* How long the testing and analysis phases took.

Comments (0)

Files changed (5)

 module Main (main) where
 
 import Control.Applicative ((<$>))
+import Control.DeepSeq (rnf)
+import Control.Exception (evaluate, finally)
 import Control.Monad (forM_, unless)
 import Data.Aeson ((.=), encode, object)
 import Data.Maybe (catMaybes)
-import Data.Text (pack)
+import Data.Text (Text, pack)
 import Data.Text.Encoding (encodeUtf8)
+import Data.Time.Clock.POSIX (getPOSIXTime)
 import Network.HTTP.LoadTest (NetworkError(..), Req(..))
 import Network.HTTP.LoadTest.Analysis (analyseBasic, analyseFull)
-import Network.HTTP.LoadTest.Report (reportBasic, reportEvents, reportFull)
+import Network.HTTP.LoadTest.Environment (environment)
+import Network.HTTP.LoadTest.Report (buildTime, reportBasic, reportEvents,
+                                     reportFull)
 import Network.Socket (withSocketsDo)
+import System.CPUTime (getCPUTime)
 import System.Console.CmdArgs
 import System.Exit (ExitCode(ExitFailure), exitWith)
 import System.IO (hPutStrLn, stderr, stdout)
 
 main :: IO ()
 main = withSocketsDo $ do
-  as@Args{..} <- cmdArgs $ defaultArgs &= program "http-load-tester"
+  as@Args{..} <- cmdArgs $ defaultArgs &= program "pronk"
   validateArgs as
   cfg <- fromArgs as <$> createRequest as
-  run <- LoadTest.run cfg
+  run <- timed "tested" $ LoadTest.run cfg
   case run of
     Left [NetworkError err] ->
       T.hprint stderr "Error: {}\n" [show err] >> exitWith (ExitFailure 1)
       exitWith (ExitFailure 1)
     Right results -> do
       whenNormal $ T.print "analysing results\n" ()
-      analysis <- if bootstrap
-                  then Right <$> analyseFull results
-                  else return . Left . analyseBasic $ results
-      let dump = object [ "config" .= cfg, "analysis" .= analysis ]
+      analysis <- timed "analysed" $ do
+                    r <- if bootstrap
+                         then Right <$> analyseFull results
+                         else return . Left . analyseBasic $ results
+                    evaluate $ rnf r
+                    return r
+      env <- environment
+      let dump = object [ "config" .= cfg
+                        , "environment" .= env
+                        , "analysis" .= analysis ]
       case json of
         Just "-" -> L.putStrLn (encode dump)
         Just f   -> L.writeFile f (encode dump)
     _ -> do
       hPutStrLn stderr "Error: --literal and --from-file are mutually exclusive"
       exitWith (ExitFailure 1)
+
+timed :: Text -> IO a -> IO a
+timed desc act = do
+  startCPU <- getCPUTime
+  startWall <- getPOSIXTime
+  act `finally` do
+    endCPU <- getCPUTime
+    endWall <- getPOSIXTime
+    let elapsedCPU  = fromIntegral (endCPU - startCPU) / 1e12
+        elapsedWall = realToFrac $ endWall - startWall
+        ratio = elapsedCPU / elapsedWall
+    whenNormal $
+      -- Try to work around the 64-bit Mac getCPUTime bug
+      -- http://hackage.haskell.org/trac/ghc/ticket/4970
+      if ratio > 0 && ratio < 32
+      then T.print "{} in {} ({}% CPU)\n"
+               (desc, buildTime 4 elapsedWall,
+                T.fixed 1 $ 100 * elapsedCPU / elapsedWall)
+      else T.print "{} in {}\n"
+               (desc, buildTime 4 elapsedWall)

lib/Network/HTTP/LoadTest/Environment.hs

+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards #-}
+
+module Network.HTTP.LoadTest.Environment
+    (
+      Environment(..)
+    , environment
+    ) where
+
+import Control.Applicative ((<$>), (<*>), empty)
+import Data.Aeson.Types (Value(..), FromJSON(..), ToJSON(..), (.:), (.=), object)
+import Data.Data (Data)
+import Data.Typeable (Typeable)
+import GHC.Conc (numCapabilities)
+import System.PosixCompat.Unistd (SystemID(..), getSystemID)
+
+data Environment = Environment {
+      osName :: String
+    , osVersion :: String
+    , hostName :: String
+    , numCores :: Int
+    } deriving (Eq, Read, Show, Typeable, Data)
+
+instance ToJSON Environment where
+    toJSON Environment{..} = object [
+                               "osName" .= osName
+                             , "osVersion" .= osVersion
+                             , "hostName" .= hostName
+                             , "numCores" .= numCores
+                             ]
+
+instance FromJSON Environment where
+    parseJSON (Object v) = Environment <$>
+                           v .: "osName" <*>
+                           v .: "osVersion" <*>
+                           v .: "hostName" <*>
+                           v .: "numCores"
+    parseJSON _ = empty
+
+environment :: IO Environment
+environment = do
+  SystemID{..} <- getSystemID
+  return Environment {
+                osName = systemName
+              , osVersion = version
+              , hostName = nodeName
+              , numCores = numCapabilities
+              }

lib/Network/HTTP/LoadTest/Report.hs

       reportBasic
     , reportEvents
     , reportFull
+    -- * Helper functions
+    , buildTime
     ) where
 
 import Control.Monad (forM_)
 import Data.Monoid (mappend)
 import Data.Text (Text)
 import Data.Text.Buildable (build)
+import Data.Text.Format (prec)
 import Data.Text.Lazy.Builder (Builder)
 import Data.Vector (Vector)
 import Network.HTTP.LoadTest.Types (Analysis(..), Basic(..), Event(..),
   print "    10%:     {} req/sec\n" [throughput10]
 
 time :: Double -> Builder
-time t
-     | t < 1e-3  = build (t * 1e6) `mappend` " usec"
-     | t < 1     = build (t * 1e3) `mappend` " msec"
-     | otherwise = build t `mappend` " sec"
+time = buildTime 6
+
+buildTime :: Int -> Double -> Builder
+buildTime precision t
+     | t < 1e-3  = prec precision (t * 1e6) `mappend` " usec"
+     | t < 1     = prec precision (t * 1e3) `mappend` " msec"
+     | otherwise = prec precision t `mappend` " sec"
 
 effect :: Handle -> OutlierVariance -> IO ()
 effect h OutlierVariance{..} =
   forM_ (sort . H.toList $ evtMap) $ \(e,n) -> do
     let nameOf 0 = "timeout "
         nameOf k = "HTTP " `mappend` build k
-    T.hprint h "    {} {}\n" (nameOf e, T.left 6 ' ' n)
+    T.hprint h "    {} {}\n" (nameOf e, T.left 7 ' ' n)
   T.hprint h "\n" ()

lib/Network/HTTP/LoadTest/Types.hs

 
 import Control.Applicative ((<$>), (<*>), empty)
 import Control.Arrow (first)
+import Control.DeepSeq (NFData(rnf))
 import Control.Exception (Exception, IOException, SomeException, try)
 import Data.Aeson.Types (Value(..), FromJSON(..), ToJSON(..), (.:), (.=), object)
 import Data.Bits (xor)
     , throughput10 :: !Double
     } deriving (Eq, Show, Typeable, Data)
 
+instance (NFData a) => NFData (Analysis a) where
+    rnf Analysis{..} = rnf latency `seq` rnf throughput
+
 data Basic = Basic {
-      mean :: !Double
-    , stdDev :: !Double
+      mean :: {-# UNPACK #-} !Double
+    , stdDev :: {-# UNPACK #-} !Double
     } deriving (Eq, Show, Typeable, Data)
 
+instance NFData Basic
+
 instance ToJSON Basic where
     toJSON Basic{..} = object [
                          "mean" .= mean
   exposed-modules:
     Network.HTTP.LoadTest
     Network.HTTP.LoadTest.Analysis
+    Network.HTTP.LoadTest.Environment
     Network.HTTP.LoadTest.Report
     Network.HTTP.LoadTest.Types
 
     bytestring,
     case-insensitive,
     criterion >= 0.5.1.0,
+    deepseq,
     hashable >= 1.1.2.0,
     http-enumerator,
     http-types,
     text,
     text-format,
     time,
+    unix-compat >= 0.2.2,
     unordered-containers >= 0.1.4.0,
     vector,
     vector-algorithms
     bytestring,
     cmdargs >= 0.7,
     criterion,
+    deepseq,
     http-enumerator,
     pronk,
     network,
     text,
-    text-format
+    text-format,
+    time
 
 source-repository head
   type:     git