config.rkt (7735B)
1 #lang racket/base 2 3 (require racket/format 4 (for-syntax syntax/kerncase 5 racket/base)) 6 7 (provide (except-out (all-from-out racket/base) 8 #%module-begin) 9 (rename-out [module-begin #%module-begin]) 10 sequential 11 parallel 12 machine 13 site-config? 14 site-config-tag 15 site-config-options 16 site-config-content 17 current-mode 18 current-stamp 19 extract-options) 20 21 (module reader syntax/module-reader 22 distro-build/config) 23 24 (struct site-config (tag options content)) 25 26 (define-syntax-rule (module-begin form ...) 27 (#%plain-module-begin (site-begin #f form ...))) 28 29 (define-syntax (site-begin stx) 30 (syntax-case stx () 31 [(_ #t) #'(begin)] 32 [(_ #f) 33 (raise-syntax-error 'site 34 "did not find an expression for the site configuration")] 35 [(_ found? next . rest) 36 (let ([expanded (local-expand #'next 'module (kernel-form-identifier-list))]) 37 (syntax-case expanded (begin) 38 [(begin next1 ...) 39 #`(site-begin found? next1 ... . rest)] 40 [(id . _) 41 (and (identifier? #'id) 42 (ormap (lambda (kw) (free-identifier=? #'id kw)) 43 (syntax->list #'(require 44 provide 45 define-values 46 define-syntaxes 47 begin-for-syntax 48 module 49 module* 50 #%require 51 #%provide)))) 52 #`(begin #,expanded (site-begin found? . rest))] 53 [_else 54 (if (syntax-e #'found?) 55 (raise-syntax-error 'site 56 "found second top-level expression" 57 #'next) 58 #`(begin 59 (provide site-config) 60 (define site-config (let ([v #,expanded]) 61 (unless (site-config? v) 62 (error 'site 63 (~a "expression did not produce a site configuration\n" 64 " result: ~e\n" 65 " expression: ~.s") 66 v 67 'next)) 68 v)) 69 (site-begin 70 #t 71 . rest)))]))])) 72 73 (define sequential 74 (make-keyword-procedure 75 (lambda (kws kw-vals . subs) 76 (constructor kws kw-vals subs 77 check-group-keyword 'sequential)))) 78 (define parallel 79 (make-keyword-procedure 80 (lambda (kws kw-vals . subs) 81 (constructor kws kw-vals subs 82 check-group-keyword 'parallel)))) 83 (define machine 84 (make-keyword-procedure 85 (lambda (kws kw-vals) 86 (constructor kws kw-vals null 87 check-machine-keyword 'machine)))) 88 89 (define (constructor kws kw-vals subs check tag) 90 (site-config 91 tag 92 (for/hash ([kw (in-list kws)] 93 [val (in-list kw-vals)]) 94 (define r (check kw val)) 95 (when (eq? r 'bad-keyword) 96 (error tag 97 (~a "unrecognized keyword for option\n" 98 " keyword: ~s") 99 kw)) 100 (unless (check kw val) 101 (error tag 102 (~a "bad value for keyword\n" 103 " keyword: ~s\n" 104 " value: ~e") 105 kw 106 val)) 107 (values kw val)) 108 (for/list ([sub subs]) 109 (unless (site-config? sub) 110 (raise-argument-error tag "site-config?" sub)) 111 sub))) 112 113 (define (check-group-keyword kw val) 114 (case kw 115 [(#:pkgs) (and (list? val) (andmap simple-string? val))] 116 [(#:racket) (or (not val) (string? val))] 117 [(#:cross-target) (simple-string? val)] 118 [(#:doc-search) (string? val)] 119 [(#:dist-name) (string? val)] 120 [(#:dist-base) (simple-string? val)] 121 [(#:dist-dir) (simple-string? val)] 122 [(#:dist-suffix) (simple-string? val)] 123 [(#:dist-catalogs) (and (list? val) (andmap string? val))] 124 [(#:dist-base-url) (string? val)] 125 [(#:install-name) (string? val)] 126 [(#:build-stamp) (string? val)] 127 [(#:max-vm) (real? val)] 128 [(#:server) (simple-string? val)] 129 [(#:server-port) (port-no? val)] 130 [(#:server-hosts) (and (list? val) (andmap simple-string? val))] 131 [(#:host) (simple-string? val)] 132 [(#:user) (or (not val) (simple-string? val))] 133 [(#:port) (port-no? val)] 134 [(#:dir) (path-string? val)] 135 [(#:env) (and (list? val) 136 (andmap (lambda (p) 137 (and (list? p) 138 (= 2 (length p)) 139 (simple-string? (car p)) 140 (string? (cadr p)))) 141 val))] 142 [(#:vbox) (string? val)] 143 [(#:platform) (memq val '(unix macosx windows windows/bash))] 144 [(#:target-platform) (memq val '(unix macosx windows #f))] 145 [(#:configure) (and (list? val) (andmap string? val))] 146 [(#:bits) (or (equal? val 32) (equal? val 64))] 147 [(#:vc) (string? val)] 148 [(#:sign-identity) (string? val)] 149 [(#:osslsigncode-args) (and (list? val) (andmap string? val))] 150 [(#:timeout) (real? val)] 151 [(#:j) (exact-positive-integer? val)] 152 [(#:repo) (string? val)] 153 [(#:clean?) (boolean? val)] 154 [(#:pull?) (boolean? val)] 155 [(#:release?) (boolean? val)] 156 [(#:source?) (boolean? val)] 157 [(#:source-runtime?) (boolean? val)] 158 [(#:source-pkgs?) (boolean? val)] 159 [(#:versionless?) (boolean? val)] 160 [(#:mac-pkg?) (boolean? val)] 161 [(#:tgz?) (boolean? val)] 162 [(#:site-dest) (path-string? val)] 163 [(#:site-help) (hash? val)] 164 [(#:site-title) (string? val)] 165 [(#:pdf-doc?) (boolean? val)] 166 [(#:max-snapshots) (real? val)] 167 [(#:plt-web-style?) (boolean? val)] 168 [(#:pause-before) (and (real? val) (not (negative? val)))] 169 [(#:pause-after) (and (real? val) (not (negative? val)))] 170 [(#:readme) (or (string? val) 171 (and (procedure? val) 172 (procedure-arity-includes? val 1)))] 173 [(#:email-to) (and (list? val) (andmap email? val))] 174 [(#:email-from) (email? val)] 175 [(#:smtp-server) (simple-string? val)] 176 [(#:smtp-port) (port-no? val)] 177 [(#:smtp-connect) (memq val '(plain ssl tls))] 178 [(#:smtp-user) (or (not val) (string? val))] 179 [(#:smtp-password) (or (not val) (string? val))] 180 [(#:custom) (and (hash? val) 181 (for/and ([k (in-hash-keys val)]) 182 (keyword? k)))] 183 [else 'bad-keyword])) 184 185 (define (check-machine-keyword kw val) 186 (case kw 187 [(#:name) (string? val)] 188 [else (check-group-keyword kw val)])) 189 190 (define (port-no? val) 191 (and (exact-integer? val) (<= 1 val 65535))) 192 193 (define (simple-string? s) 194 (and (string? s) 195 ;; No spaces, quotes, or other things that could 196 ;; break a command-line, path, or URL construction: 197 (regexp-match #rx"^[-a-zA-Z0-9._]*$" s))) 198 199 (define (email? s) 200 (and (string? s) 201 (regexp-match? #rx"@" s))) 202 203 (define current-mode (make-parameter "default")) 204 205 (define current-stamp 206 (let* ([f (build-path "build" "stamp.txt")] 207 [s (and (file-exists? f) 208 (call-with-input-file* f read-line))]) 209 (lambda () 210 (if (string? s) 211 s 212 "now")))) 213 214 (define (extract-options config-file config-mode) 215 (parameterize ([current-mode config-mode]) 216 (site-config-options 217 (dynamic-require (path->complete-path config-file) 'site-config))))