distro-build: add support for e-mail report on build

original commit: ddd0eb2d9de85cab40cbe06b8d8e808bcbe224a6

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

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
+  #:site-dest <path-string> --- destination for completed build, used
-    description of the installer and can be used in a generated table of
+    by the `site' and `snapshot-site' makefile targets; the default is
-    installer links; see also "Names and Download Pages" below
+    "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

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))))

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)])))

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")