{-# LANGUAGE NamedFieldPuns, RecordWildCards, ScopedTypeVariables, CPP, BangPatterns #-}
{-# LANGUAGE TupleSections, DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
-- | CodeSpeed website upload of benchmark data.
--
-- This module must be used in conjunction with the main "hsbencher" package,
-- e.g. "import HSBencher", and then "import HSBencher.Backend.CodeSpeed" and
-- add the plugin
module HSBencher.Backend.Codespeed
( -- * The plugin itself, what you probably want
defaultCodespeedPlugin
-- * Details and configuration options.
, CodespeedConfig(..)
-- , stdRetry, getTableId
-- , fusionSchema, resultToTuple
-- , uploadBenchResult
, CodespeedPlug(), CodespeedCmdLnFlag(..),
)
where
import Control.Monad.Reader
import Control.Concurrent (threadDelay)
import qualified Control.Exception as E
import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe)
import Data.Dynamic
import Data.Default (Default(..))
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.List as L
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.ByteString.Char8 as BS
import Data.Time.Clock
import Data.Time.Calendar
import Data.Time.Format ()
import Network.HTTP.Types (renderQuery, urlEncode, urlDecode)
import Network.HTTP (simpleHTTP, postRequestWithBody)
import Control.Monad.Trans.Resource (runResourceT)
import Text.JSON -- (encodeStrict, toJSObject)
import HSBencher.Types
import HSBencher.Internal.Logging (log)
import Prelude hiding (log)
import System.IO (hPutStrLn, stderr)
import System.IO.Unsafe (unsafePerformIO)
import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)
import System.Directory (doesFileExist, doesDirectoryExist, getAppUserDataDirectory,
createDirectory, renameFile, removeFile)
import System.FilePath ((</>),(<.>), splitExtension)
import System.IO.Unsafe (unsafePerformIO)
import System.Environment (getEnvironment)
import System.Exit
import Control.Concurrent.MVar
--------------------------------------------------------------------------------
-- | A default plugin. This binding provides future-proof way to get
-- a default instance of the plugin, in the eventuality that more
-- configuration options are added in the future.
defaultCodespeedPlugin :: CodespeedPlug
defaultCodespeedPlugin = CodespeedPlug
-- | This is the same as defaultCodespeedPlugin
instance Default CodespeedPlug where
def = defaultCodespeedPlugin
-- TODO: may need to grab stdRetry / retryIORequest from the Fusion plugin..
-- | Configuration options for Codespeed uploading.
data CodespeedConfig =
CodespeedConfig { codespeedURL :: URL
, projName :: String }
deriving (Show,Read,Ord,Eq, Typeable)
-- | Note, the default config may not be complete and thus may have
-- some required fields to fill in, or errors will ensue.
instance Default CodespeedConfig where
def = CodespeedConfig
{ codespeedURL = error "incomplete CodespeedConfig: Must set Codespeed URL (--codespeed) to use this plugin!"
, projName = error "incomplete CodespeedConfig: Must set Codespeed --projname to use this plugin!"
}
-- | Parsed command line options provided by the user that initiaties benchmarking.
data CodespeedCmdLnFlag = CodespeedURL URL
| CodespeedProjName String
-- TODO: Authentication!
deriving (Show,Read,Ord,Eq, Typeable)
type URL = String
getDateTime :: IO String
getDateTime = do
utc <- getCurrentTime
return $ show utc
-- | Push the results from a single benchmark to the server.
uploadBenchResult :: BenchmarkResult -> BenchM ()
uploadBenchResult br = do
lift$ putStrLn " [codespeed] Begin upload of one benchmark result."
conf <- ask
-- Look up our configuration dynamically based the plugin type:
let codespeedConfig = getMyConf CodespeedPlug conf
-- lift$ putStrLn$ " [codespeed] Running with config: \n"++show conf
lift$ putStrLn$ " [codespeed] Running with plugin config: \n"++show codespeedConfig
let CodespeedConfig {codespeedURL} = codespeedConfig
contentType = "application/x-www-form-urlencoded"
-- contentType = "application/json"
addURL = (codespeedURL ++ "/result/add/json/")
-- Version that uses HTTP pkg:
let json = renderJSONResult codespeedConfig br
bod = urlEncode False $ BS.pack json
let req = postRequestWithBody addURL contentType $ BS.unpack bod
lift$ putStrLn$ " [codespeed] Uploading json: "++ json
lift$ putStrLn$ " [codespeed] URl-encoded json POST body: "++ BS.unpack bod
lift$ putStrLn$ " [codespeed] Submitting HTTP Post request: \n"++show req
resp <- lift$ simpleHTTP req
case resp of
Left err -> lift$ putStrLn$ " [codespeed] ERROR uploading: \n"++show err
Right x -> lift$ putStrLn$ " [codespeed] Got response from server:\n"++show x
return ()
renderJSONResult :: CodespeedConfig -> BenchmarkResult -> String
renderJSONResult CodespeedConfig{projName} benchRes =
-- _PROGNAME _VARIANT _ARGS _HOSTNAME _RUNID _CI_BUILD_ID _THREADS
-- _DATETIME _MINTIME _MEDIANTIME _MAXTIME _MINTIME_PRODUCTIVITY
-- _MEDIANTIME_PRODUCTIVITY _MAXTIME_PRODUCTIVITY _ALLTIMES _TRIALS
-- _COMPILER _COMPILE_FLAGS _RUNTIME_FLAGS _ENV_VARS _BENCH_VERSION
-- _BENCH_FILE _UNAME _PROCESSOR _TOPOLOGY _GIT_BRANCH _GIT_HASH
-- _GIT_DEPTH _WHO _ETC_ISSUE _LSPCI _FULL_LOG _MEDIANTIME_ALLOCRATE
-- _MEDIANTIME_MEMFOOTPRINT _ALLJITTIMES _CUSTOM
simpleFormat
[
-- A working example:
-- ("project", S "MyProject2")
-- , ("executable", S "myexe 04 32bits")
-- , ("benchmark", S "float")
-- , ("commitid", S "8")
-- , ("environment", S "cutter")
-- , ("result_value", D 2500.1)
-- , ("branch", S "default")
("project", S projName)
, ("executable", S exec)
, ("benchmark", S bench)
, ("commitid", S _GIT_HASH)
-- , ("environment", S "129-79-241-98") -- Results in 400 / BAD REQUEST
-- , ("environment", S "1297924198") -- Results in 400 / BAD REQUEST
-- Apparently this is the error on the server:
-- Exception Value:
-- Expecting ',' delimiter: line 1 column 235 (char 234)
-- Exception Location: /opt/python/2.7.8/lib/python2.7/json/decoder.py in raw_decode, line 382
-- , ("environment", S "hello1297924198") -- Results in 400 / BAD REQUEST
-- , ("environment", S "hello") -- Also 400 / BAD REQUEST
-- Seems to fail if the environment is not REGISTERED already
-- on the website. Does not create on demand?
, ("environment", S _HOSTNAME)
, ("result_value", D _MEDIANTIME)
, ("branch", S _GIT_BRANCH)
-- Plus add optional fields:
-- , ("revision_date", s "") -- Optional. Default is taken either
-- -- from VCS integration or from current date
-- , ("result_date", s "") -- Optional, default is current date
-- , ("std_dev", showJSON (1.11111 :: Double)) -- Optional. Default is blank
, ("max", D _MAXTIME) -- Optional. Default is blank
, ("min", D _MINTIME) -- Optional. Default is blank
-- RRN: Question: are max and min the *observed* max and min presumably?
]
where
-- Populate the CodeSpeed fields using the HSBencher fields:
BenchmarkResult{..} = benchRes
exec = combine $ [_VARIANT] ++ if _THREADS==0 then []
else [show _THREADS ++ "T"]
bench = combine [_PROGNAME, unwords _ARGS]
-- | This is a hacky way to pack multiple fields into one field of the
-- destination schema. There is a tradeoff here between readability
-- and ease of dissection.
combine :: [String] -> String
combine fields =
let fields' = filter (not . null) fields in
L.concat (L.intersperse "|" fields')
data RHS = S String | D Double
-- | The Django-based codespeed server is a bit finicky in exactly
-- what JSON formattincg and URL encodings it accepts. Thus, rather
-- than using any of the existing frameworks, we just use a particular
-- format we know works.
simpleFormat :: [(String,RHS)] -> String
simpleFormat prs = "json=[{" ++ bod ++"}]"
where
bod = L.concat $ L.intersperse ", " $ L.map fn prs
fn (l,r) = show l ++ ": " ++ rhs r
rhs (S s) = show s
rhs (D d) = show d
-- | The type of Codespeed table plugins. Currently this is a singleton type; there is
-- really only one Codespeed plugin.
data CodespeedPlug = CodespeedPlug
deriving (Eq,Show,Ord,Read)
instance Plugin CodespeedPlug where
-- These configs are stored in a dynamically typed list within the global BenchM config:
type PlugConf CodespeedPlug = CodespeedConfig
type PlugFlag CodespeedPlug = CodespeedCmdLnFlag
-- | Better be globally unique! Careful.
plugName _ = "codespeed"
plugCmdOpts _ = codespeed_cli_options
plugUploadRow p cfg row = runReaderT (uploadBenchResult row) cfg
plugInitialize p gconf = do
putStrLn " [codespeed] Codespeed table plugin initializing.. (which is a NOOP)"
return gconf
foldFlags p flgs cnf0 =
foldr ($) cnf0 (map doFlag flgs)
where
doFlag (CodespeedURL url) r = r { codespeedURL = url}
doFlag (CodespeedProjName nm) r = r { projName = nm }
theEnv :: [(String,String)]
theEnv = unsafePerformIO getEnvironment
-- | All the command line options understood by this plugin.
codespeed_cli_options :: (String, [OptDescr CodespeedCmdLnFlag])
codespeed_cli_options =
("Codespeed Table Options:",
[ Option [] ["codespeed"] (ReqArg CodespeedURL "URL")
"specify the root URL of the Codespeed installation"
, Option [] ["projname"] (ReqArg CodespeedProjName "NAME")
"specify which Codespeed Project receives the uploaded results"
])