218 lines
7.6 KiB
Racket
218 lines
7.6 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/format
|
|
(for-syntax syntax/kerncase
|
|
racket/base))
|
|
|
|
(provide (except-out (all-from-out racket/base)
|
|
#%module-begin)
|
|
(rename-out [module-begin #%module-begin])
|
|
sequential
|
|
parallel
|
|
machine
|
|
site-config?
|
|
site-config-tag
|
|
site-config-options
|
|
site-config-content
|
|
current-mode
|
|
current-stamp
|
|
extract-options)
|
|
|
|
(module reader syntax/module-reader
|
|
distro-build/config)
|
|
|
|
(struct site-config (tag options content))
|
|
|
|
(define-syntax-rule (module-begin form ...)
|
|
(#%plain-module-begin (site-begin #f form ...)))
|
|
|
|
(define-syntax (site-begin stx)
|
|
(syntax-case stx ()
|
|
[(_ #t) #'(begin)]
|
|
[(_ #f)
|
|
(raise-syntax-error 'site
|
|
"did not find an expression for the site configuration")]
|
|
[(_ found? next . rest)
|
|
(let ([expanded (local-expand #'next 'module (kernel-form-identifier-list))])
|
|
(syntax-case expanded (begin)
|
|
[(begin next1 ...)
|
|
#`(site-begin found? next1 ... . rest)]
|
|
[(id . _)
|
|
(and (identifier? #'id)
|
|
(ormap (lambda (kw) (free-identifier=? #'id kw))
|
|
(syntax->list #'(require
|
|
provide
|
|
define-values
|
|
define-syntaxes
|
|
begin-for-syntax
|
|
module
|
|
module*
|
|
#%require
|
|
#%provide))))
|
|
#`(begin #,expanded (site-begin found? . rest))]
|
|
[_else
|
|
(if (syntax-e #'found?)
|
|
(raise-syntax-error 'site
|
|
"found second top-level expression"
|
|
#'next)
|
|
#`(begin
|
|
(provide site-config)
|
|
(define site-config (let ([v #,expanded])
|
|
(unless (site-config? v)
|
|
(error 'site
|
|
(~a "expression did not produce a site configuration\n"
|
|
" result: ~e\n"
|
|
" expression: ~.s")
|
|
v
|
|
'next))
|
|
v))
|
|
(site-begin
|
|
#t
|
|
. rest)))]))]))
|
|
|
|
(define sequential
|
|
(make-keyword-procedure
|
|
(lambda (kws kw-vals . subs)
|
|
(constructor kws kw-vals subs
|
|
check-group-keyword 'sequential))))
|
|
(define parallel
|
|
(make-keyword-procedure
|
|
(lambda (kws kw-vals . subs)
|
|
(constructor kws kw-vals subs
|
|
check-group-keyword 'parallel))))
|
|
(define machine
|
|
(make-keyword-procedure
|
|
(lambda (kws kw-vals)
|
|
(constructor kws kw-vals null
|
|
check-machine-keyword 'machine))))
|
|
|
|
(define (constructor kws kw-vals subs check tag)
|
|
(site-config
|
|
tag
|
|
(for/hash ([kw (in-list kws)]
|
|
[val (in-list kw-vals)])
|
|
(define r (check kw val))
|
|
(when (eq? r 'bad-keyword)
|
|
(error tag
|
|
(~a "unrecognized keyword for option\n"
|
|
" keyword: ~s")
|
|
kw))
|
|
(unless (check kw val)
|
|
(error tag
|
|
(~a "bad value for keyword\n"
|
|
" keyword: ~s\n"
|
|
" value: ~e")
|
|
kw
|
|
val))
|
|
(values kw val))
|
|
(for/list ([sub subs])
|
|
(unless (site-config? sub)
|
|
(raise-argument-error tag "site-config?" sub))
|
|
sub)))
|
|
|
|
(define (check-group-keyword kw val)
|
|
(case kw
|
|
[(#:pkgs) (and (list? val) (andmap simple-string? val))]
|
|
[(#:racket) (or (not val) (string? val))]
|
|
[(#:cross-target) (simple-string? val)]
|
|
[(#:doc-search) (string? val)]
|
|
[(#:dist-name) (string? val)]
|
|
[(#:dist-base) (simple-string? val)]
|
|
[(#:dist-dir) (simple-string? val)]
|
|
[(#:dist-suffix) (simple-string? val)]
|
|
[(#:dist-catalogs) (and (list? val) (andmap string? val))]
|
|
[(#:dist-base-url) (string? val)]
|
|
[(#:install-name) (string? val)]
|
|
[(#:build-stamp) (string? val)]
|
|
[(#:max-vm) (real? val)]
|
|
[(#:server) (simple-string? val)]
|
|
[(#: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) (port-no? val)]
|
|
[(#:dir) (path-string? val)]
|
|
[(#:env) (and (list? val)
|
|
(andmap (lambda (p)
|
|
(and (list? p)
|
|
(= 2 (length p))
|
|
(simple-string? (car p))
|
|
(string? (cadr p))))
|
|
val))]
|
|
[(#:vbox) (string? val)]
|
|
[(#:platform) (memq val '(unix macosx windows windows/bash))]
|
|
[(#:target-platform) (memq val '(unix macosx windows #f))]
|
|
[(#:configure) (and (list? val) (andmap string? val))]
|
|
[(#:bits) (or (equal? val 32) (equal? val 64))]
|
|
[(#:vc) (string? val)]
|
|
[(#:sign-identity) (string? val)]
|
|
[(#:osslsigncode-args) (and (list? val) (andmap string? val))]
|
|
[(#:timeout) (real? val)]
|
|
[(#:j) (exact-positive-integer? val)]
|
|
[(#:repo) (string? val)]
|
|
[(#:clean?) (boolean? val)]
|
|
[(#:pull?) (boolean? val)]
|
|
[(#:release?) (boolean? val)]
|
|
[(#:source?) (boolean? val)]
|
|
[(#:source-runtime?) (boolean? val)]
|
|
[(#:source-pkgs?) (boolean? val)]
|
|
[(#:versionless?) (boolean? val)]
|
|
[(#:mac-pkg?) (boolean? val)]
|
|
[(#:tgz?) (boolean? val)]
|
|
[(#:site-dest) (path-string? val)]
|
|
[(#:site-help) (hash? val)]
|
|
[(#:site-title) (string? val)]
|
|
[(#:pdf-doc?) (boolean? val)]
|
|
[(#:max-snapshots) (real? val)]
|
|
[(#:plt-web-style?) (boolean? val)]
|
|
[(#:pause-before) (and (real? val) (not (negative? val)))]
|
|
[(#:pause-after) (and (real? val) (not (negative? val)))]
|
|
[(#: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)))]
|
|
[else 'bad-keyword]))
|
|
|
|
(define (check-machine-keyword kw val)
|
|
(case kw
|
|
[(#: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-Z0-9._]*$" s)))
|
|
|
|
(define (email? s)
|
|
(and (string? s)
|
|
(regexp-match? #rx"@" s)))
|
|
|
|
(define current-mode (make-parameter "default"))
|
|
|
|
(define current-stamp
|
|
(let* ([f (build-path "build" "stamp.txt")]
|
|
[s (and (file-exists? f)
|
|
(call-with-input-file* f read-line))])
|
|
(lambda ()
|
|
(if (string? s)
|
|
s
|
|
"now"))))
|
|
|
|
(define (extract-options config-file config-mode)
|
|
(parameterize ([current-mode config-mode])
|
|
(site-config-options
|
|
(dynamic-require (path->complete-path config-file) 'site-config))))
|