1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
#lang racket
(require web-server/servlet
web-server/servlet-env
(for-syntax racket)
(for-syntax syntax/kerncase))
(provide
(all-from-out web-server/servlet)
(except-out (all-from-out racket) #%module-begin)
(rename-out [web-module-begin #%module-begin]))
(define extra-files-path #f)
(define launch-browser? #t)
(provide/contract
[static-files-path (path-string? . -> . void?)])
(define (static-files-path path)
(set! extra-files-path path))
(provide/contract
[no-web-browser (-> void)])
(define (no-web-browser)
(set! launch-browser? false))
;; check-for-def : syntax syntax-list -> void
;; Expands body-stxs and determines if id-stx is bound therein.
;; If not error w/ error-msg. stx is the root syntax context for everything
(define-for-syntax (check-for-def stx id-stx error-msg body-stxs)
(with-syntax ([(pmb body ...)
(local-expand
(quasisyntax/loc stx
(#%module-begin #,@body-stxs))
'module-begin
empty)])
(let loop ([syns (syntax->list #'(body ...))])
(if (empty? syns)
(raise-syntax-error 'insta error-msg stx)
(kernel-syntax-case (first syns) #t
[(define-values (id ...) expr)
(unless
(ormap (lambda (id)
(and (identifier? id)
(free-identifier=? id id-stx)))
(syntax->list #'(id ...)))
(loop (rest syns)))
]
[_
(loop (rest syns))])))
(quasisyntax/loc stx
(pmb body ...))))
(define-syntax (web-module-begin stx)
(syntax-case stx ()
[(_ body ...)
(let* ([start (datum->syntax stx 'start)]
[expanded (check-for-def stx
start "You must provide a 'start' request handler."
#'(body ...))])
(quasisyntax/loc stx
(#,@expanded
(provide/contract (#,start (request? . -> . can-be-response?)))
(serve/servlet (contract (request? . -> . can-be-response?) #,start
'you 'web-server
"start"
#f)
#:port 0
#:extra-files-paths (if extra-files-path (list extra-files-path) empty)
#:launch-browser? launch-browser?))))]))
|
