diff --git a/pkgs/distro-build/config.rkt b/pkgs/distro-build/config.rkt index 0c2d3bb..6294d0c 100644 --- 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 index 9997d2d..ed16a93 100644 --- a/pkgs/distro-build/doc.txt +++ b/pkgs/distro-build/doc.txt @@ -116,6 +116,10 @@ Site-configuration keywords (where means no spaces, etc.): #:host --- defaults to "localhost" + #:name --- 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 --- SSH port for the client; defaults to 22 #:user --- SSH user for the client; defaults to #f, @@ -254,13 +258,6 @@ Site-configuration keywords (where means no spaces, etc.): when the `#:source-runtime?' value is also #t; the default is the value of `#:source?' - #:site-dest --- destination for completed build, used - by the `site' and `snapshot-site' makefile targets; the default is - "build/site" - - #:pdf-doc? --- whether to build PDF documentation when - assembling a site; the default is #f - #:max-snapshots --- number of snapshots to keep, used by the `snapshot-site' makefile target @@ -279,11 +276,32 @@ Site-configuration keywords (where 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 --- 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 --- destination for completed build, used + by the `site' and `snapshot-site' makefile targets; the default is + "build/site" + + #:pdf-doc? --- whether to build PDF documentation when + assembling a site; the default is #f + + #:email-to --- a list of addresses to receive + e-mail reporting build results; mail is sent via `sendmail' + unless `#:smtp-...' configuration is supplied + + #:email-from --- address used as the sender of e-mailed + reports; the first string in `#:email-to' is used by default + + #:smtp-server + #:smtp-port + #:smtp-connect <'plain, 'ssl, or 'tls> + #:smtp-user + #:smtp-password + --- 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 index a25c66c..0cc2c05 100644 --- 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 new file mode 100644 index 0000000..5bb24bf --- /dev/null +++ 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 index 6fd6e8b..5809249 100644 --- 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")