diff --git a/HSBencher/Backend/Codespeed.hs b/HSBencher/Backend/Codespeed.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Backend/Codespeed.hs @@ -0,0 +1,246 @@ +{-# 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" + ]) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Ryan Newton + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ryan Newton nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hsbencher-codespeed.cabal b/hsbencher-codespeed.cabal new file mode 100644 --- /dev/null +++ b/hsbencher-codespeed.cabal @@ -0,0 +1,34 @@ + +name: hsbencher-codespeed +version: 0.1 +synopsis: Backend for uploading benchmark data to CodeSpeed +description: The CodeSpeed project provides a performance dashboard and + is described at 'https://github.com/tobami/codespeed'. +license: BSD3 +license-file: LICENSE +author: Ryan Newton +maintainer: rrnewton@gmail.com +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.18 + +library + exposed-modules: HSBencher.Backend.Codespeed + build-depends: base >=4.5 && < 4.8, + containers >=0.5, bytestring >=0.10, + time >=1.4, directory >=1.2, filepath >=1.3, + mtl, +-- TODO: need to come forward to modern http-conduit: +-- http-conduit >=2.0 && <2.1, + http-conduit >= 1.9.0, + HTTP >= 4000.2.18, + http-types >= 0.8, + resourcet >= 0.4, + json >= 0.7, + network == 2.5.0.0, + data-default >= 0.5.3, + hsbencher >= 1.11 && < 2.0 + default-language: Haskell2010 +