sunet/web-server/start-extended-web-server

178 lines
5.5 KiB
Plaintext
Executable File

#!/bin/sh
echo "Loading..."
exec scsh -lel SSAX-4.9/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
httpd-rman-gateway
httpd-info-gateway
let-opt
scsh
scheme
srfi-37)
(begin
(define (usage)
(format #f
"Usage: start-extended-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)
requests maximal amount of simultaneous requests (default 5)
--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
a maximum of ~a simultaneous requests, syslogging activated,
and home-dir-handler (public_html) activated.
"
(lookup-option options 'htdocs-dir)
(lookup-option options 'cgi-bin-dir)
(lookup-option options 'port)
(lookup-option options 'log-file-name)
(lookup-option options 'requests))
(httpd (make-httpd-options
with-port (lookup-option options 'port)
with-root-directory (cwd)
with-simultaneous-requests (lookup-option options 'requests)
with-syslog? #t
with-log-file (lookup-option options 'log-file-name)
with-post-bind-thunk become-nobody-if-root
with-request-handler
(alist-path-dispatcher
(list (cons "seval" seval-handler)
;; You may want to adapt this to your site.
;; call like http://localhost:8080/man/man?ssh(1)
(cons "man" (rman-handler 'man
'nroff
"/usr/X11R6/bin/rman"
"/usr/bin/zcat"
#f "man?%s(%s)"
"Generated by rman-gateway"))
;; call like http://localhost:8080/info/info?(slib.info)Top
;; note: can only handle not-gzipped info files
(cons "info" (info-handler #f #f #f
"Generated by info-gateway"))
(cons "cgi-bin" (cgi-handler
(lookup-option options 'cgi-bin-dir))))
(tilde-home-dir-handler "public_html"
(rooted-file-or-directory-handler
(lookup-option options htdocs-dir)))))))))
))
;; EOF
;;; Local Variables:
;;; mode:scheme
;;; End: