suzanne.soy/distro-build
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
original commit: ddd0eb2d9de85cab40cbe06b8d8e808bcbe224a6
This commit is contained in:
Matthew Flatt 2013-11-03 08:32:55 -07:00
parent d19e124bd3
commit 19b488e135
5 changed files with 142 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/distro-build/config.rkt
View File

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

40
pkgs/distro-build/doc.txt
View File

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

22
pkgs/distro-build/drive-clients.rkt
View File

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

74
pkgs/distro-build/email.rkt Normal file
View File

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

3
pkgs/distro-build/info.rkt
View File

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