buildbot: add support for uploading results via scp

diff --git a/dph-buildbot/src/Args.hs b/dph-buildbot/src/Args.hs
index 9d58fcd..1139e6b 100644 (file)
--- a/dph-buildbot/src/Args.hs
+++ b/dph-buildbot/src/Args.hs
@@ -31,9 +31,11 @@ data BuildArg
        | ArgTestIterations
        | ArgMailFrom 
        | ArgMailTo
+       | ArgMailBanner
        | ArgSendTestMail
        | ArgWriteResults
        | ArgWriteResultsStamped
+       | ArgUploadResults
        | ArgAgainstResults
        | ArgSwingFraction
        deriving (Eq, Ord, Show)
@@ -160,18 +162,30 @@ buildArgs
                , argData       = argDataOptional "file" ArgtypeString
                , argDesc       = "(opt. for test modes)  ... appending a time stamp to the name." }            
 
+       , Arg   { argIndex      = ArgUploadResults
+               , argAbbr       = Just 'u'
+               , argName       = Just "upload"
+               , argData       = argDataOptional "scp-path" ArgtypeString
+               , argDesc       = "(opt. for test modes)  ... and scp the results to this path." }
+
        , Arg   { argIndex      = ArgMailFrom
                , argAbbr       = Nothing
-               , argName       = Just "mailfrom"
+               , argName       = Just "mail-from"
                , argData       = argDataOptional "address" ArgtypeString
                , argDesc       = "(opt. for test modes) Send test results from this address." }
 
        , Arg   { argIndex      = ArgMailTo
                , argAbbr       = Nothing
-               , argName       = Just "mailto"
+               , argName       = Just "mail-to"
                , argData       = argDataOptional "address" ArgtypeString
                , argDesc       = "(opt. for test modes)  ... to this address." }                       
 
+       , Arg   { argIndex      = ArgMailBanner
+               , argAbbr       = Nothing
+               , argName       = Just "mail-banner"
+               , argData       = argDataOptional "file" ArgtypeString
+               , argDesc       = "(opt. for test modes)  ... appending the banner to the front of the message." }
+
        -- Setup debugging
        , Arg   { argIndex      = ArgSendTestMail
                , argAbbr       = Nothing

diff --git a/dph-buildbot/src/BuildTest.hs b/dph-buildbot/src/BuildTest.hs
index 46a5bce..c3d18d3 100644 (file)
--- a/dph-buildbot/src/BuildTest.hs
+++ b/dph-buildbot/src/BuildTest.hs
@@ -71,26 +71,39 @@ buildTest config env
                , buildResultEnvironment        = env
                , buildResultBench              = benchResults }
 
-       -- Write results to a file if requested.        
-       maybe   (return ())
-               (\(fileName, shouldStamp) -> do
+       -- Compute comparisons against the baseline file.
+       let resultComparisons
+               = compareManyBenchResults 
+                       (resultsPrior)
+                       (map statBenchResult benchResults)
+
+       -- Write results to a file if requested.
+       resultFiles
+        <- maybe (return (error "results file has not been written"))
+                 (\(fileName, shouldStamp) -> do
                        stamp   <- if shouldStamp
                                        then io $ getStampyTime
                                        else return ""
-                                       
-                       
+                                               
                        let fileName'   = fileName ++ stamp
                        
                        outLn $ "* Writing results to " ++ fileName'
-                       io $ writeFile fileName' $ show buildResults)
+                       io $ writeFile fileName'                $ show buildResults
+                       io $ writeFile (fileName' ++ ".txt")    $ render $ reportBenchResults Nothing resultComparisons
+
+                       return [fileName', fileName' ++ ".txt"])
+                       
                (configWriteResults config)
        
 
-       -- Compute comparisons against the baseline file.
-       let resultComparisons
-               = compareManyBenchResults 
-                       (resultsPrior)
-                       (map statBenchResult benchResults)
+       -- Upload results if requesed,
+       --      this requires that they be written to file as above.
+       maybe   (return ())
+               (\uploadPath -> do
+                       outLn $ "* Uploading results to " ++ uploadPath
+                       mapM_ (\file -> ssystem $ "scp " ++ file ++ " " ++ uploadPath) resultFiles)
+                       
+               (configUploadResults config)
 
        
        -- Mail results to recipient if requested.
@@ -98,24 +111,31 @@ buildTest config env
        maybe   (return ())
                (\(from, to) -> do
                        outLn $ "* Mailing results to " ++ to 
-                       mail    <- createMailWithCurrentTime from to "[nightly] DPH Performance Test Succeeded"
-                               $ render $ vcat
-                               [ text "DPH Performance Test Succeeded"
-                               , blank
-                               , ppr env
-                               , blank
-                               , spaceHack $ render $ reportBenchResults (configSwingFraction config) resultComparisons
-                               , blank ]
+                       
+                       banner  <- maybe        
+                                       (return blank)
+                                       (\file -> (io $ readFile file) >>= return . text)
+                                       (configMailBanner config)
+                       
+                       mail    <- createMailWithCurrentTime from to 
+                                       "[nightly] DPH Performance Test Succeeded"
+                                       $ render $ vcat
+                                       [ banner
+                                       , ppr env
+                                       , blank
+                                       , spaceHack $ render $ reportBenchResults (configSwingFraction config) resultComparisons
+                                       , blank ]
                        
                        outLn $ "  - Writing mail file"
                        io $ writeFile "dph-buildbot.mail" $ render $ renderMail mail
                                
                        outLn $ "  - Sending mail"
-                       sendMailWithMailer mail defaultMailer                           
+                       sendMailWithMailer mail defaultMailer
                        return ())
                (configMailFromTo config)
 
 
+
 -- | Parse a noslow benchmark results files.
 parseNoSlowLog :: String -> [BenchResult Single]
 parseNoSlowLog str

diff --git a/dph-buildbot/src/Config.hs b/dph-buildbot/src/Config.hs
index d1ef9a0..c93f773 100644 (file)
--- a/dph-buildbot/src/Config.hs
+++ b/dph-buildbot/src/Config.hs
@@ -45,7 +45,9 @@ data Config
 
        -- What do with the results.
        , configWriteResults    :: Maybe (FilePath, Bool)
-       , configMailFromTo      :: Maybe (String, String) }
+       , configMailFromTo      :: Maybe (String, String)
+       , configMailBanner      :: Maybe String
+       , configUploadResults   :: Maybe String }
        deriving Show
 
 
@@ -139,7 +141,8 @@ slurpConfig args
                                                | otherwise
                                                = Nothing
                                          in  result
-                                               
+               
+               , configUploadResults   = getArg args ArgUploadResults                          
                , configAgainstResults  = getArg args ArgAgainstResults
                , configSwingFraction   = getArg args ArgSwingFraction
 
@@ -152,4 +155,6 @@ slurpConfig args
                                                | otherwise
                                                = Nothing
                                                in      result
+
+               , configMailBanner      = getArg args ArgMailBanner
                }