drive-clients.rkt (21944B)
1 #lang racket/base 2 (require racket/cmdline 3 racket/system 4 racket/port 5 racket/format 6 racket/file 7 racket/string 8 racket/path 9 net/base64 10 (only-in distro-build/config 11 current-mode 12 site-config? 13 site-config-tag site-config-options site-config-content 14 current-stamp) 15 distro-build/url-options 16 distro-build/display-time 17 distro-build/readme 18 remote-shell/vbox 19 "email.rkt") 20 21 ;; See "config.rkt" for an overview. 22 23 (module test racket/base) 24 25 ;; ---------------------------------------- 26 27 (define default-release? #f) 28 (define default-source? #f) 29 (define default-versionless? #f) 30 (define default-clean? #f) 31 (define dry-run #f) 32 33 (define snapshot-install-name "snapshot") 34 35 (define-values (config-file config-mode 36 default-server default-server-port default-server-hosts 37 default-pkgs default-doc-search 38 default-dist-name default-dist-base default-dist-dir) 39 (command-line 40 #:once-each 41 [("--release") "Create release-mode installers" 42 (set! default-release? #t)] 43 [("--source") "Create source installers" 44 (set! default-source? #t)] 45 [("--versionless") "Avoid version number in names and paths" 46 (set! default-versionless? #t)] 47 [("--clean") "Erase client directories before building" 48 (set! default-clean? #t)] 49 [("--dry-run") mode 50 ("Don't actually use the clients;" 51 " <mode> can be `ok', `fail', `error', `stuck', or `frozen'") 52 (unless (member mode '("ok" "fail" "error" "stuck" "frozen")) 53 (raise-user-error 'drive-clients "bad dry-run mode: ~a" mode)) 54 (set! dry-run (string->symbol mode))] 55 #:args (config-file config-mode 56 server server-port server-hosts pkgs doc-search 57 dist-name dist-base dist-dir) 58 (values config-file config-mode 59 server server-port server-hosts pkgs doc-search 60 dist-name dist-base dist-dir))) 61 62 (define config (parameterize ([current-mode config-mode]) 63 (dynamic-require (path->complete-path config-file) 'site-config))) 64 65 (unless (site-config? config) 66 (error 'drive-clients 67 "configuration module did not provide a site-configuration value: ~e" 68 config)) 69 70 ;; ---------------------------------------- 71 72 (define (merge-options opts c) 73 (for/fold ([opts opts]) ([(k v) (in-hash (site-config-options c))]) 74 (if (eq? k '#:custom) 75 (hash-set opts 76 '#:custom 77 (let ([prev (hash-ref opts '#:custom (hash))]) 78 (for/fold ([prev prev]) ([(k2 v2) (in-hash v)]) 79 (hash-set prev k2 v2)))) 80 (hash-set opts k v)))) 81 82 (define (get-opt opts kw [default #f] #:localhost [localhost-default default]) 83 (hash-ref opts kw (lambda () 84 (cond 85 [(equal? default localhost-default) default] 86 [(and (equal? "localhost" (get-opt opts '#:host "localhost")) 87 (equal? #f (get-opt opts '#:user #f)) 88 (equal? #f (get-opt opts '#:dir #f))) 89 localhost-default] 90 [else default])))) 91 92 (define (get-content c) 93 (site-config-content c)) 94 95 (define (client-name opts) 96 (or (get-opt opts '#:name) 97 (get-opt opts '#:host) 98 "localhost")) 99 100 (define (get-path-opt opt key default #:localhost [localhost-default default]) 101 (define d (get-opt opt key default #:localhost localhost-default)) 102 (if (path? d) 103 (path->string d) 104 d)) 105 106 (define (add-defaults c . l) 107 (let loop ([c c] [l l]) 108 (cond 109 [(null? l) c] 110 [else (loop (hash-set c (car l) 111 (hash-ref c (car l) (lambda () (cadr l)))) 112 (cddr l))]))) 113 114 ;; ---------------------------------------- 115 ;; Managing VirtualBox machines 116 117 (define (start-client c max-vm) 118 (define vbox (get-opt c '#:vbox)) 119 (when vbox 120 (start-vbox-vm vbox 121 #:max-vms max-vm 122 #:dry-run? dry-run))) 123 124 (define (stop-client c) 125 (define vbox (get-opt c '#:vbox)) 126 (when vbox 127 (stop-vbox-vm vbox))) 128 129 (define (try-until-ready c host port user server-port kind cmd) 130 (when (get-opt c '#:vbox) 131 ;; A VM may take a little while to get networking set up and 132 ;; respond, so give a dummy `cmd` a few tries 133 (let loop ([tries 3]) 134 (unless (ssh-script host port user server-port kind cmd) 135 (sleep 1) 136 (loop (sub1 tries)))))) 137 138 ;; ---------------------------------------- 139 140 (define scp (find-executable-path "scp")) 141 (define ssh (find-executable-path "ssh")) 142 143 (define (system*/show exe . args) 144 (displayln (apply ~a #:separator " " 145 (map (lambda (p) (if (path? p) (path->string p) p)) 146 (cons exe args)))) 147 (flush-output) 148 (case dry-run 149 [(ok) #t] 150 [(fail) #f] 151 [(error) (error "error")] 152 [(stuck) (semaphore-wait (make-semaphore))] 153 [(frozen) (break-enabled #f) (semaphore-wait (make-semaphore))] 154 [else 155 (apply system* exe args)])) 156 157 (define (ssh-script host port user server-port kind . cmds) 158 (for/and ([cmd (in-list cmds)]) 159 (when cmd (display-time)) 160 (or (not cmd) 161 (if (and (equal? host "localhost") 162 (not user)) 163 (apply system*/show cmd) 164 (apply system*/show ssh 165 "-p" (~a port) 166 ;; create tunnel to connect back to server: 167 "-R" (~a server-port ":localhost:" server-port) 168 (if user 169 (~a user "@" host) 170 host) 171 (if (eq? kind 'unix) 172 ;; ssh needs an extra level of quoting 173 ;; relative to sh: 174 (for/list ([arg (in-list cmd)]) 175 (~a "'" 176 (regexp-replace* #rx"'" arg "'\"'\"'") 177 "'")) 178 ;; windows quoting built into `cmd' aready 179 cmd)))))) 180 181 (define (q s) 182 (~a "\"" s "\"")) 183 184 (define (qq l kind) 185 (case kind 186 [(unix macosx) 187 (~a "'" 188 (apply ~a #:separator " " (map q l)) 189 "'")] 190 [(windows windows/bash) 191 (~a "\"" 192 (apply 193 ~a #:separator " " 194 (for/list ([i (in-list l)]) 195 (~a "\\\"" 196 i 197 ;; A backslash is literal unless followed by a 198 ;; quote. If `i' ends in backslashes, they 199 ;; must be doubled, because the \" added to 200 ;; the end will make them treated as escapes. 201 (let ([m (regexp-match #rx"\\\\*$" i)]) 202 (car m)) 203 "\\\""))) 204 "\"")])) 205 206 (define (shell-protect s kind) 207 (case kind 208 [(windows/bash) 209 ;; Protect Windows arguments to go through bash, where 210 ;; unquoted backslashes must be escaped, but quotes are effectively 211 ;; preserved by the shell, and quoted backslashes should be left 212 ;; alone; also, "&&" must be quoted to avoid parsing by bash 213 (regexp-replace* "&&" 214 (list->string 215 ;; In practice, the following loop is likely to 216 ;; do nothing, because constructed command lines 217 ;; tend to have only quoted backslashes. 218 (let loop ([l (string->list s)] [in-quote? #f]) 219 (cond 220 [(null? l) null] 221 [(and (equal? #\\ (car l)) 222 (not in-quote?)) 223 (list* #\\ #\\ (loop (cdr l) #f))] 224 [(and in-quote? 225 (equal? #\\ (car l)) 226 (pair? (cdr l)) 227 (or (equal? #\" (cadr l)) 228 (equal? #\\ (cadr l)))) 229 (list* #\\ (cadr l) (loop (cddr l) #t))] 230 [(equal? #\" (car l)) 231 (cons #\" (loop (cdr l) (not in-quote?)))] 232 [else 233 (cons (car l) (loop (cdr l) in-quote?))]))) 234 "\"\\&\\&\"")] 235 [else s])) 236 237 (define (pack-base64-arguments args) 238 (bytes->string/utf-8 (base64-encode (string->bytes/utf-8 (format "~s" args)) 239 #""))) 240 241 (define (client-args c server server-port kind readme) 242 (define desc (client-name c)) 243 (define pkgs (let ([l (get-opt c '#:pkgs)]) 244 (if l 245 (apply ~a #:separator " " l) 246 default-pkgs))) 247 (define racket (get-opt c '#:racket)) 248 (define doc-search (choose-doc-search c default-doc-search)) 249 (define dist-name (or (get-opt c '#:dist-name) 250 default-dist-name)) 251 (define dist-base (or (get-opt c '#:dist-base) 252 default-dist-base)) 253 (define dist-dir (or (get-opt c '#:dist-dir) 254 default-dist-dir)) 255 (define dist-suffix (get-opt c '#:dist-suffix "")) 256 (define dist-catalogs (choose-catalogs c '(""))) 257 (define sign-identity (get-opt c '#:sign-identity "")) 258 (define osslsigncode-args (get-opt c '#:osslsigncode-args)) 259 (define release? (get-opt c '#:release? default-release?)) 260 (define source? (get-opt c '#:source? default-source?)) 261 (define versionless? (get-opt c '#:versionless? default-versionless?)) 262 (define source-pkgs? (get-opt c '#:source-pkgs? source?)) 263 (define source-runtime? (get-opt c '#:source-runtime? source?)) 264 (define mac-pkg? (get-opt c '#:mac-pkg? #f)) 265 (define tgz? (get-opt c '#:tgz? #f)) 266 (define install-name (get-opt c '#:install-name (if release? 267 "" 268 snapshot-install-name))) 269 (define build-stamp (get-opt c '#:build-stamp (if release? 270 "" 271 (current-stamp)))) 272 (~a " SERVER=" server 273 " SERVER_PORT=" server-port 274 " PKGS=" (q pkgs) 275 (if racket 276 (~a " PLAIN_RACKET=" (q racket)) 277 "") 278 " DOC_SEARCH=" (q doc-search) 279 " DIST_DESC=" (q desc) 280 " DIST_NAME=" (q dist-name) 281 " DIST_BASE=" dist-base 282 " DIST_DIR=" dist-dir 283 " DIST_SUFFIX=" (q dist-suffix) 284 " DIST_CATALOGS_q=" (qq dist-catalogs kind) 285 " SIGN_IDENTITY=" (q sign-identity) 286 " OSSLSIGNCODE_ARGS_BASE64=" (q (if osslsigncode-args 287 (pack-base64-arguments osslsigncode-args) 288 "")) 289 " INSTALL_NAME=" (q install-name) 290 " BUILD_STAMP=" (q build-stamp) 291 " RELEASE_MODE=" (if release? "--release" (q "")) 292 " SOURCE_MODE=" (if source-runtime? "--source" (q "")) 293 " VERSIONLESS_MODE=" (if versionless? "--versionless" (q "")) 294 " PKG_SOURCE_MODE=" (if source-pkgs? 295 (q "--source --no-setup") 296 (q "")) 297 " MAC_PKG_MODE=" (if mac-pkg? "--mac-pkg" (q "")) 298 " TGZ_MODE=" (if tgz? "--tgz" (q "")) 299 " UPLOAD=http://" server ":" server-port "/upload/" 300 " README=http://" server ":" server-port "/" (q (file-name-from-path readme)))) 301 302 (define (unix-build c platform host port user server server-port repo clean? pull? readme) 303 (define dir (get-path-opt c '#:dir "build/plt" #:localhost (current-directory))) 304 (define env (get-opt c '#:env null)) 305 (define (sh . args) 306 (append 307 (if (null? env) 308 null 309 (list* "/usr/bin/env" 310 (for/list ([e (in-list env)]) 311 (format "~a=~a" (car e) (cadr e))))) 312 (list "/bin/sh" "-c" (apply ~a args)))) 313 (define j (or (get-opt c '#:j) 1)) 314 (define cross-target (get-opt c '#:cross-target)) 315 (define given-racket (and cross-target 316 (get-opt c '#:racket))) 317 (define need-native-racket? (and cross-target 318 (not given-racket))) 319 (define built-native-racket "cross/racket/racket3m") ; relative to build directory 320 (try-until-ready c host port user server-port 'unix (sh "echo hello")) 321 (ssh-script 322 host port user 323 server-port 324 'unix 325 (and clean? 326 (sh "rm -rf " (q dir))) 327 (sh "if [ ! -d " (q dir) " ] ; then" 328 " git clone " (q repo) " " (q dir) " ; " 329 "fi") 330 (and pull? 331 (sh "cd " (q dir) " ; " 332 "git pull")) 333 (and need-native-racket? 334 (sh "cd " (q dir) " ; " 335 "make -j " j " native-for-cross")) 336 (sh "cd " (q dir) " ; " 337 "make -j " j " client" 338 (client-args c server server-port 'unix readme) 339 " JOB_OPTIONS=\"-j " j "\"" 340 (if need-native-racket? 341 (~a " PLAIN_RACKET=`pwd`/racket/src/build/" built-native-racket) 342 "") 343 " CONFIGURE_ARGS_qq=" (qq (append 344 (if cross-target 345 (list (~a "--enable-racket=" 346 (or given-racket 347 (~a "`pwd`/" built-native-racket))) 348 (~a "--host=" cross-target)) 349 null) 350 (get-opt c '#:configure null)) 351 'unix)))) 352 353 (define (windows-build c platform host port user server server-port repo clean? pull? readme) 354 (define dir (get-path-opt c '#:dir "build\\plt" #:localhost (current-directory))) 355 (define bits (or (get-opt c '#:bits) 64)) 356 (define vc (or (get-opt c '#:vc) 357 (if (= bits 32) 358 "x86" 359 "x86_amd64"))) 360 (define j (or (get-opt c '#:j) 1)) 361 (define (cmd . args) 362 (list "cmd" "/c" (shell-protect (apply ~a args) platform))) 363 (try-until-ready c host port user server-port 'windows (cmd "echo hello")) 364 (ssh-script 365 host port user 366 server-port 367 platform 368 (and clean? 369 (cmd "IF EXIST " (q dir) " rmdir /S /Q " (q dir))) 370 (cmd "IF NOT EXIST " (q dir) " git clone " (q repo) " " (q dir)) 371 (and pull? 372 (cmd "cd " (q dir) 373 " && git pull")) 374 (cmd "cd " (q dir) 375 " && racket\\src\\worksp\\msvcprep.bat " vc 376 " && nmake win32-client" 377 " JOB_OPTIONS=\"-j " j "\"" 378 (client-args c server server-port platform readme)))) 379 380 (define (client-build c) 381 (define host (or (get-opt c '#:host) 382 "localhost")) 383 (define port (or (get-opt c '#:port) 384 22)) 385 (define user (get-opt c '#:user)) 386 (define server (or (get-opt c '#:server) 387 default-server)) 388 (define server-port (or (get-opt c '#:server-port) 389 default-server-port)) 390 (define repo (or (get-opt c '#:repo) 391 (~a "http://" server ":" server-port "/.git"))) 392 (define clean? (get-opt c '#:clean? default-clean? #:localhost #f)) 393 (define pull? (get-opt c '#:pull? #t #:localhost #f)) 394 395 (define readme-txt (let ([rdme (get-opt c '#:readme make-readme)]) 396 (if (string? rdme) 397 rdme 398 (rdme (add-defaults c 399 '#:release? default-release? 400 '#:source? default-source? 401 '#:versionless? default-versionless? 402 '#:pkgs (string-split default-pkgs) 403 '#:install-name (if (get-opt c '#:release? default-release?) 404 "" 405 snapshot-install-name) 406 '#:build-stamp (if (get-opt c '#:release? default-release?) 407 "" 408 (current-stamp))))))) 409 (make-directory* (build-path "build" "readmes")) 410 (define readme (make-temporary-file 411 "README-~a" 412 #f 413 (build-path "build" "readmes"))) 414 (call-with-output-file* 415 readme 416 #:exists 'truncate 417 (lambda (o) 418 (display readme-txt o) 419 (unless (regexp-match #rx"\n$" readme-txt) 420 ;; ensure a newline at the end: 421 (newline o)))) 422 423 (define platform (or (get-opt c '#:platform) (system-type))) 424 425 (begin0 426 427 ((case platform 428 [(unix macosx) unix-build] 429 [else windows-build]) 430 c platform host port user server server-port repo clean? pull? readme) 431 432 (delete-file readme))) 433 434 ;; ---------------------------------------- 435 436 (define stop? #f) 437 438 (define failures (make-hasheq)) 439 (define (record-failure name) 440 ;; relies on atomicity of `eq?'-based hash table: 441 (hash-set! failures (string->symbol name) #t)) 442 443 (define (limit-and-report-failure c timeout-factor 444 shutdown report-fail 445 thunk) 446 (define cust (make-custodian)) 447 (define timeout (or (get-opt c '#:timeout) 448 (* 30 60))) 449 (define orig-thread (current-thread)) 450 (define timeout? #f) 451 (begin0 452 (parameterize ([current-custodian cust]) 453 (thread (lambda () 454 (sleep (* timeout-factor timeout)) 455 (eprintf "timeout for ~s\n" (client-name c)) 456 ;; try nice interrupt, first: 457 (set! timeout? #t) 458 (break-thread orig-thread) 459 (sleep 1) 460 ;; force quit: 461 (report-fail) 462 (shutdown))) 463 (with-handlers ([exn? (lambda (exn) 464 (when (exn:break? exn) 465 ;; This is useful only when everything is 466 ;; sequential, which is the only time that 467 ;; we'll get break events that aren't timeouts: 468 (unless timeout? 469 (set! stop? #t))) 470 (log-error "~a failed..." (client-name c)) 471 (log-error (exn-message exn)) 472 (report-fail) 473 #f)]) 474 (thunk))) 475 (custodian-shutdown-all cust))) 476 477 (define (client-thread c all-seq? proc) 478 (unless stop? 479 (define log-dir (build-path "build" "log")) 480 (define log-file (build-path log-dir (client-name c))) 481 (make-directory* log-dir) 482 (printf "Logging build: ~a\n" log-file) 483 (flush-output) 484 (define cust (make-custodian)) 485 (define (go shutdown) 486 (define p (open-output-file log-file 487 #:exists 'truncate/replace)) 488 (file-stream-buffer-mode p 'line) 489 (define (report-fail) 490 (record-failure (client-name c)) 491 (printf "Build FAILED for ~s\n" (client-name c))) 492 (unless (parameterize ([current-output-port p] 493 [current-error-port p]) 494 (proc shutdown report-fail)) 495 (report-fail)) 496 (display-time)) 497 (cond 498 [all-seq? 499 (go (lambda () (exit 1))) 500 (thread void)] 501 [else 502 (parameterize ([current-custodian cust]) 503 (thread 504 (lambda () 505 (go (lambda () 506 (custodian-shutdown-all cust))))))]))) 507 508 ;; ---------------------------------------- 509 510 (define start-seconds (current-seconds)) 511 (display-time) 512 513 (void 514 (sync 515 (let loop ([config config] 516 [all-seq? #t] ; Ctl-C handling is better if nothing is in parallel 517 [opts (hasheq)]) 518 (cond 519 [stop? (thread void)] 520 [else 521 (case (site-config-tag config) 522 [(parallel) 523 (define new-opts (merge-options opts config)) 524 (define ts 525 (map (lambda (c) (loop c #f new-opts)) 526 (get-content config))) 527 (thread 528 (lambda () 529 (for ([t (in-list ts)]) 530 (sync t))))] 531 [(sequential) 532 (define new-opts (merge-options opts config)) 533 (define (go) 534 (for-each (lambda (c) (sync (loop c all-seq? new-opts))) 535 (get-content config))) 536 (if all-seq? 537 (begin (go) (thread void)) 538 (thread go))] 539 [else 540 (define c (merge-options opts config)) 541 (client-thread 542 c 543 all-seq? 544 (lambda (shutdown report-fail) 545 (limit-and-report-failure 546 c 2 shutdown report-fail 547 (lambda () 548 (sleep (get-opt c '#:pause-before 0)) 549 ;; start client, if a VM: 550 (start-client c (or (get-opt c '#:max-vm) 1)) 551 ;; catch failure in build step proper, so we 552 ;; can more likely stop the client: 553 (begin0 554 (limit-and-report-failure 555 c 1 shutdown report-fail 556 (lambda () (client-build c))) 557 ;; stop client, if a VM: 558 (stop-client c) 559 (sleep (get-opt c '#:pause-after 0)))))))])])))) 560 561 (display-time) 562 (define end-seconds (current-seconds)) 563 564 (unless stop? 565 (let ([opts (merge-options (hasheq) config)]) 566 (let ([to-email (get-opt opts '#:email-to null)]) 567 (unless (null? to-email) 568 (printf "Sending report to ~a\n" (apply ~a to-email #:separator ", ")) 569 (send-email to-email (lambda (key def) 570 (get-opt opts key def)) 571 (get-opt opts '#:build-stamp (current-stamp)) 572 start-seconds end-seconds 573 (hash-map failures (lambda (k v) (symbol->string k)))) 574 (display-time)))))