82 lines
3.0 KiB
Scheme
82 lines
3.0 KiB
Scheme
#lang scheme
|
|
(require scheme/cmdline
|
|
scheme/unit
|
|
mzlib/pregexp
|
|
net/tcp-sig
|
|
net/tcp-unit
|
|
net/ssl-tcp-unit)
|
|
(require "../configuration/configuration-table.ss"
|
|
(except-in "../web-server.ss" serve)
|
|
"../web-config-unit.ss")
|
|
|
|
; this is used by launchers
|
|
; extract-flag : sym (listof (cons sym alpha)) alpha -> alpha
|
|
(define (extract-flag name flags default)
|
|
(let ([x (assq name flags)])
|
|
(if x
|
|
(cdr x)
|
|
default)))
|
|
|
|
(define ssl (make-parameter #f))
|
|
(define port (make-parameter #f))
|
|
|
|
(define configuration@
|
|
(parse-command-line
|
|
"plt-web-server"
|
|
(current-command-line-arguments)
|
|
`((once-each
|
|
[("--ssl")
|
|
,(lambda (flag)
|
|
(unless (port) (port 443))
|
|
(ssl #t))
|
|
("Run with SSL using server-cert.pem and private-key.pem in the current directory, with 443 as the default port.")]
|
|
[("-f" "--configuration-table")
|
|
,(lambda (flag file-name)
|
|
(cond
|
|
[(not (file-exists? file-name))
|
|
(error 'web-server "configuration file ~s not found" file-name)]
|
|
[(not (memq 'read (file-or-directory-permissions file-name)))
|
|
(error 'web-server "configuration file ~s is not readable" file-name)]
|
|
[else (cons 'config (string->path file-name))]))
|
|
("Use an alternate configuration table" "file-name")]
|
|
[("-p" "--port")
|
|
,(lambda (flag the-port)
|
|
(let ([p (string->number the-port)])
|
|
(if (and (integer? p) (<= 1 p 65535))
|
|
(port p)
|
|
(error 'web-server "expecting a valid port number, got \"~a\"" the-port))))
|
|
("Use an alternate network port." "port")]
|
|
[("-a" "--ip-address")
|
|
,(lambda (flag ip-address)
|
|
; note the double backslash I initially left out. That's a good reason to use Olin's regexps.
|
|
(let ([addr (pregexp-split "\\." ip-address)])
|
|
(if (and (= 4 (length addr))
|
|
(andmap (lambda (s)
|
|
(let ([n (string->number s)])
|
|
(and (integer? n) (<= 0 n 255))))
|
|
addr))
|
|
(cons 'ip-address ip-address)
|
|
(error 'web-server "ip-address expects a numeric ip-address (i.e. 127.0.0.1); given ~s" ip-address))))
|
|
("Restrict access to come from ip-address" "ip-address")]))
|
|
(lambda (flags)
|
|
(configuration-table->web-config@
|
|
(extract-flag 'config flags default-configuration-table-path)
|
|
#:port (port)
|
|
#:listen-ip (extract-flag 'ip-address flags #f)))
|
|
'()))
|
|
|
|
(define (serve)
|
|
(serve/web-config@
|
|
configuration@
|
|
#:tcp@ (if (ssl)
|
|
(let ()
|
|
(define-unit-binding ssl-tcp@
|
|
(make-ssl-tcp@ (build-path (current-directory) "server-cert.pem")
|
|
(build-path (current-directory) "private-key.pem")
|
|
#f #f #f #f #f)
|
|
(import) (export tcp^))
|
|
ssl-tcp@)
|
|
tcp@)))
|
|
|
|
(provide serve)
|