160 lines
4.8 KiB
Plaintext
Executable File
160 lines
4.8 KiB
Plaintext
Executable File
#!/bin/sh
|
|
echo "Loading..."
|
|
exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e main -s "$0" "$@"
|
|
!#
|
|
|
|
(define-structure http-test
|
|
(export main)
|
|
(open httpd-core
|
|
httpd-make-options
|
|
httpd-basic-handlers
|
|
httpd-file-directory-handlers
|
|
httpd-cgi-handlers
|
|
httpd-seval-handlers
|
|
scheme-with-scsh
|
|
srfi-37)
|
|
|
|
(begin
|
|
|
|
(define (usage)
|
|
(format #f
|
|
"Usage: start-web-server
|
|
[-h DIR | --htdocs-dir=DIR] [-c DIR | --cgi-bin-dir=DIR]
|
|
[-l FILE | --log-file-name=FILE] [-r NUM | --requests=NUM]
|
|
[-p NUM | --port=NUM]
|
|
[--help]
|
|
|
|
with
|
|
htdocs-dir directory of html files (default: root/htdocs)
|
|
cgi-bin-dir directory of cgi files (default: root/cgi-bin)
|
|
port port server is listening to (default: 8080)
|
|
log-file-name directory where to store the logfile in CLF
|
|
(default: /tmp/httpd.log)
|
|
--help show this help
|
|
"))
|
|
|
|
(define (display-usage)
|
|
(display (usage) (current-error-port))
|
|
(exit 1))
|
|
|
|
(define (raise-usage-error msg . info)
|
|
(display msg (current-error-port))
|
|
(for-each
|
|
(lambda (i)
|
|
(display i (current-error-port))
|
|
(display " " (current-error-port)))
|
|
info)
|
|
(display "\n" (current-error-port))
|
|
(exit 1))
|
|
|
|
(define (parse-arguments arg-list)
|
|
(let ((number-option-proc
|
|
(lambda (alist-key)
|
|
(lambda (option name arg ops)
|
|
(cond
|
|
((not arg)
|
|
(raise-usage-error "Option requires a number" name arg))
|
|
((string->number arg)
|
|
=> (lambda (n) (cons (cons alist-key n) ops)))
|
|
(else
|
|
(raise-usage-error "Not a number" arg))))))
|
|
(absolute-file-name-proc
|
|
(lambda (alist-key)
|
|
(lambda (option name arg ops)
|
|
(cons (cons alist-key
|
|
(absolute-file-name arg)) ops)))))
|
|
|
|
(let ((htdocs-dir-option
|
|
(option '(#\h "htdocs-dir") #t #f
|
|
(absolute-file-name-proc 'htdocs-dir)))
|
|
(cgi-bin-dir-option
|
|
(option '(#\c "cgi-bin-dir") #t #f
|
|
(absolute-file-name-proc 'cgi-bin-dir)))
|
|
(port-option
|
|
(option '(#\p "port") #t #f
|
|
(number-option-proc 'port)))
|
|
(log-file-name-option
|
|
(option '(#\l "log-file-name") #t #f
|
|
(absolute-file-name-proc 'log-file-name)))
|
|
(requests-option
|
|
(option '(#\r "requests") #t #f
|
|
(number-option-proc 'requests)))
|
|
(help-option
|
|
(option '(#f "help") #f #f
|
|
(lambda (option name arg ops)
|
|
(display-usage)))))
|
|
(args-fold arg-list
|
|
(list htdocs-dir-option cgi-bin-dir-option
|
|
port-option log-file-name-option
|
|
requests-option help-option)
|
|
(lambda (op name arg ops)
|
|
(raise-usage-error
|
|
"Unknown command line argument: " name))
|
|
cons
|
|
'()))))
|
|
|
|
(define (make-options-from-args cmd-line-args default-options)
|
|
(let ((given (parse-arguments cmd-line-args)))
|
|
(map (lambda (p)
|
|
(or (assoc (car p) given) p))
|
|
default-options)))
|
|
|
|
(define (lookup-option alist option)
|
|
(cond
|
|
((assoc option alist)
|
|
=> cdr)
|
|
(else
|
|
(error "Internal error, option not found" option alist))))
|
|
|
|
(define (become-nobody-if-root)
|
|
(cond ((zero? (user-uid))
|
|
(set-gid (->gid "nobody"))
|
|
(set-uid (->uid "nobody")))))
|
|
|
|
(define (main args)
|
|
(with-cwd
|
|
(file-name-directory (car args))
|
|
(let* ((default-options
|
|
`((htdocs-dir . ,(absolute-file-name "root/htdocs"))
|
|
(cgi-bin-dir . ,(absolute-file-name "root/cgi-bin"))
|
|
(port . 8080)
|
|
(log-file-name . "/tmp/httpd.log")
|
|
(requests . 5)))
|
|
(options (make-options-from-args (cdr args) default-options)))
|
|
|
|
(format #t "Going to run Webserver with:
|
|
htdocs-dir: ~a
|
|
cgi-bin-dir: ~a
|
|
port: ~a
|
|
log-file-name: ~a
|
|
syslogging activated.
|
|
"
|
|
(lookup-option options 'htdocs-dir)
|
|
(lookup-option options 'cgi-bin-dir)
|
|
(lookup-option options 'port)
|
|
(lookup-option options 'log-file-name))
|
|
|
|
(httpd (make-httpd-options
|
|
with-port (lookup-option options 'port)
|
|
with-root-directory (cwd)
|
|
with-syslog? #t
|
|
with-log-file (lookup-option options 'log-file-name)
|
|
with-post-bind-thunk become-nobody-if-root
|
|
;; The following settings are made to avoid dns lookups.
|
|
with-reported-port (lookup-option options 'port)
|
|
with-fqdn "localhost"
|
|
with-resolve-ips? #f
|
|
with-request-handler
|
|
(alist-path-dispatcher
|
|
(list (cons "cgi-bin" (cgi-handler (lookup-option options 'cgi-bin-dir)))
|
|
(cons "seval" seval-handler))
|
|
(tilde-home-dir-handler "public_html"
|
|
(rooted-file-or-directory-handler
|
|
(lookup-option options 'htdocs-dir)))))))))
|
|
))
|
|
;; EOF
|
|
|
|
;;; Local Variables:
|
|
;;; mode:scheme
|
|
;;; End:
|