commit 19b488e1356ced8cbeb5101c2104da6e71760e09
parent d19e124bd397a6d7829a403cec4d3cfc8d0d90de
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 3 Nov 2013 08:32:55 -0700
distro-build: add support for e-mail report on build
original commit: ddd0eb2d9de85cab40cbe06b8d8e808bcbe224a6
Diffstat:
5 files changed, 142 insertions(+), 15 deletions(-)
diff --git a/pkgs/distro-build/config.rkt b/pkgs/distro-build/config.rkt
@@ -124,11 +124,11 @@
[(#:build-stamp) (string? val)]
[(#:max-vm) (real? val)]
[(#:server) (simple-string? val)]
- [(#:server-port) (and (exact-integer? val) (<= 1 val 65535))]
+ [(#:server-port) (port-no? val)]
[(#:server-hosts) (and (list? val) (andmap simple-string? val))]
[(#:host) (simple-string? val)]
[(#:user) (or (not val) (simple-string? val))]
- [(#:port) (and (exact-integer? val) (<= 1 val 65535))]
+ [(#:port) (port-no? val)]
[(#:dir) (path-string? val)]
[(#:vbox) (string? val)]
[(#:platform) (memq val '(unix macosx windows windows/bash))]
@@ -153,6 +153,13 @@
[(#:readme) (or (string? val)
(and (procedure? val)
(procedure-arity-includes? val 1)))]
+ [(#:email-to) (and (list? val) (andmap email? val))]
+ [(#:email-from) (email? val)]
+ [(#:smtp-server) (simple-string? val)]
+ [(#:smtp-port) (port-no? val)]
+ [(#:smtp-connect) (memq val '(plain ssl tls))]
+ [(#:smtp-user) (or (not val) (string? val))]
+ [(#:smtp-password) (or (not val) (string? val))]
[(#:custom) (and (hash? val)
(for/and ([k (in-hash-keys val)])
(keyword? k)))]
@@ -163,12 +170,19 @@
[(#:name) (string? val)]
[else (check-group-keyword kw val)]))
+(define (port-no? val)
+ (and (exact-integer? val) (<= 1 val 65535)))
+
(define (simple-string? s)
(and (string? s)
;; No spaces, quotes, or other things that could
;; break a command-line, path, or URL construction:
(regexp-match #rx"^[-a-zA-A0-9.]*$" s)))
+(define (email? s)
+ (and (string? s)
+ (regexp-match? #rx"@" s)))
+
(define current-mode (make-parameter "default"))
(define current-stamp
diff --git a/pkgs/distro-build/doc.txt b/pkgs/distro-build/doc.txt
@@ -116,6 +116,10 @@ Site-configuration keywords (where <string*> means no spaces, etc.):
#:host <string*> --- defaults to "localhost"
+ #:name <string> --- defaults to host; this string is recorded as a
+ description of the installer and can be used in a generated table of
+ installer links; see also "Names and Download Pages" below
+
#:port <integer> --- SSH port for the client; defaults to 22
#:user <string*/false> --- SSH user for the client; defaults to #f,
@@ -254,13 +258,6 @@ Site-configuration keywords (where <string*> means no spaces, etc.):
when the `#:source-runtime?' value is also #t; the default is the
value of `#:source?'
- #:site-dest <path-string> --- destination for completed build, used
- by the `site' and `snapshot-site' makefile targets; the default is
- "build/site"
-
- #:pdf-doc? <boolean> --- whether to build PDF documentation when
- assembling a site; the default is #f
-
#:max-snapshots <number> --- number of snapshots to keep, used by
the `snapshot-site' makefile target
@@ -279,11 +276,32 @@ Site-configuration keywords (where <string*> means no spaces, etc.):
than the built-in ones, where additional entires may be useful to
a `#:readme' procedure
-Machine-only keywords:
+Top keywords (recognized only in the configuration top-level):
- #:name <string> --- defaults to host; this string is recorded as a
- description of the installer and can be used in a generated table of
- installer links; see also "Names and Download Pages" below
+ #:site-dest <path-string> --- destination for completed build, used
+ by the `site' and `snapshot-site' makefile targets; the default is
+ "build/site"
+
+ #:pdf-doc? <boolean> --- whether to build PDF documentation when
+ assembling a site; the default is #f
+
+ #:email-to <listof-of-string> --- a list of addresses to receive
+ e-mail reporting build results; mail is sent via `sendmail'
+ unless `#:smtp-...' configuration is supplied
+
+ #:email-from <string> --- address used as the sender of e-mailed
+ reports; the first string in `#:email-to' is used by default
+
+ #:smtp-server <string*>
+ #:smtp-port <string*>
+ #:smtp-connect <'plain, 'ssl, or 'tls>
+ #:smtp-user <string-or-#f>
+ #:smtp-password <string-or-#f>
+ --- configuration for sending e-mail through SMTP instead of
+ `sendmail'; the `#:smtp-port' default (25, 465, or 587) is picked
+ based on `#:smtp-connect', which in turn defaults to 'plain;
+ supply non-#f `#:smtp-user' and `#:smtp-password' when
+ authentication is required by the server
More precisely, the `distro-build/config' language is like
`racket/base' except that the module body must have exactly one
diff --git a/pkgs/distro-build/drive-clients.rkt b/pkgs/distro-build/drive-clients.rkt
@@ -13,7 +13,8 @@
current-stamp)
"url-options.rkt"
"display-time.rkt"
- "readme.rkt")
+ "readme.rkt"
+ "email.rkt")
;; See "config.rkt" for an overview.
@@ -407,6 +408,8 @@
;; ----------------------------------------
(define stop? #f)
+(define failures null)
+(define failures-sema (make-semaphore 1))
(define (limit-and-report-failure c timeout-factor thunk)
(unless stop?
@@ -449,6 +452,10 @@
(unless (parameterize ([current-output-port p]
[current-error-port p])
(thunk))
+ (call-with-semaphore
+ failures-sema
+ (lambda ()
+ (set! failures (cons (client-name c) failures))))
(printf "Build FAILED for ~s\n" (client-name c))))
(cond
[sequential? (go) (thread void)]
@@ -456,6 +463,7 @@
;; ----------------------------------------
+(define start-seconds (current-seconds))
(display-time)
(void
@@ -500,3 +508,15 @@
(sleep (get-opt c '#:pause-after 0)))))))]))))
(display-time)
+(define end-seconds (current-seconds))
+
+(let ([opts (merge-options (hasheq) config)])
+ (let ([to-email (get-opt opts '#:email-to null)])
+ (unless (null? to-email)
+ (printf "Sending report to ~a\n" (apply ~a to-email #:separator ", "))
+ (send-email to-email (lambda (key def)
+ (get-opt opts key def))
+ (get-opt opts '#:build-stamp (current-stamp))
+ start-seconds end-seconds
+ failures)
+ (display-time))))
diff --git a/pkgs/distro-build/email.rkt b/pkgs/distro-build/email.rkt
@@ -0,0 +1,74 @@
+#lang racket/base
+(require racket/format
+ net/head
+ net/smtp
+ net/sendmail
+ openssl
+ racket/tcp)
+
+(provide send-email)
+
+(define (send-email to-email get-opt
+ stamp
+ start-seconds end-seconds
+ failures)
+ (let ([server (get-opt '#:smtp-server #f)]
+ [from-email (or (get-opt '#:email-from #f)
+ (car to-email))]
+ [subject (~a "[build] "
+ (if (null? failures)
+ "success"
+ "FAILURE")
+ " " stamp)]
+ [message (append
+ (if (null? failures)
+ '("All builds succeeded.")
+ (cons
+ "The following builds failed:"
+ (for/list ([i (in-list failures)])
+ (~a " " i))))
+ (list
+ ""
+ (let ([e (- end-seconds start-seconds)]
+ [~d (lambda (n)
+ (~a n #:width 2 #:pad-string "0" #:align 'right))])
+ (~a "Elapsed time: "
+ (~d (quotient e (* 60 60)))
+ ":"
+ (~d (modulo (quotient e (* 60)) 60))
+ ":"
+ (~d (modulo e (* 60 60)))))
+ ""
+ (~a "Stamp: " stamp)))])
+ (cond
+ [server
+ (let* ([smtp-connect (get-opt '#:smtp-connect 'plain)]
+ [port-no (get-opt '#:smtp-port
+ (case smtp-connect
+ [(plain) 25]
+ [(ssl) 465]
+ [(tls) 587]))])
+ (smtp-send-message server
+ #:port-no port-no
+ #:tcp-connect (if (eq? 'ssl smtp-connect)
+ ssl-connect
+ tcp-connect)
+ #:tls-encode (and (eq? 'tls smtp-connect)
+ ports->ssl-ports)
+ #:auth-user (get-opt '#:smtp-user #f)
+ #:auth-passwd (get-opt '#:smtp-password #f)
+ from-email
+ to-email
+ (standard-message-header from-email
+ to-email
+ null
+ null
+ subject)
+ message))]
+ [else
+ (send-mail-message from-email
+ subject
+ to-email
+ null
+ null
+ message)])))
diff --git a/pkgs/distro-build/info.rkt b/pkgs/distro-build/info.rkt
@@ -4,7 +4,8 @@
(define deps '("base"
"web-server-lib"
- "ds-store-lib"))
+ "ds-store-lib"
+ "net-lib"))
(define build-deps '("at-exp-lib"))
(define pkg-desc "Tools for constructing a distribution of Racket")
