From b7314f87f16a44a92ddc5a40b7e360b5e0757743 Mon Sep 17 00:00:00 2001 From: eknauel Date: Mon, 9 Feb 2004 08:09:35 +0000 Subject: [PATCH] + Use SRFI-37 (arg-fold) for parsing command-line-arguments --- start-surflet-server | 281 +++++++++++++++++++++---------------------- 1 file changed, 135 insertions(+), 146 deletions(-) diff --git a/start-surflet-server b/start-surflet-server index c534d9d..b0c2316 100755 --- a/start-surflet-server +++ b/start-surflet-server @@ -18,16 +18,20 @@ exec scsh -lel sunet-2.1/load.scm -lel ssax/load.scm -dm -o surflet-server -e ma surflet-handler surflet-handler/options let-opt - scsh - scheme) + scsh + scheme + srfi-37 + signals) (begin (define (usage) (format #f -"Usage: start-surflet-server [-h htdocs-dir] [-s surflet-dir] [-i images-dir] - [-p port] [-l log-file-name] - [-r requests] [--help] +"Usage: start-surflet-server + [-h DIR | --htdocs-dir=DIR] [-s DIR | --surflet-dir=DIR] + [-i DIR | --images-dir=DIR] [-p NUM | --port=NUM] + [-l FILE | --log-file-name=FILE] [-r NUM | --requests=NUM] + [--help] with htdocs-dir directory of html files (default: ./web-server/root/htdocs) @@ -39,104 +43,93 @@ exec scsh -lel sunet-2.1/load.scm -lel ssax/load.scm -dm -o surflet-server -e ma requests maximal amount of simultaneous requests (default 5) --help show this help - NOTE: This is the SUrflet-server. It does not support cgi-bin. -" - )) + NOTE: This is the SUrflet-server. It does not support cgi-bin.~%")) - (define htdocs-dir #f) - (define images-dir #f) -; (define cgi-bin-dir #f) - (define port #f) - (define log-file-name #f) - (define root #f) - (define surflet-dir #f) - (define simultaneous-requests #f) + (define (display-usage) + (display (usage) (current-error-port)) + (exit 1))1 - (define (init) - (set! htdocs-dir "root/htdocs") - (set! images-dir "root/img") -; (set! cgi-bin-dir "./web-server/root/cgi-bin") - (set! port "8008") - (set! log-file-name "httpd.log") - (set! root "root") - (set! surflet-dir "root/surflets") - (set! simultaneous-requests "5")) + (define default-options + `((htdocs-dir . ,(absolute-file-name "root/htdocs")) + (surflet-dir . ,(absolute-file-name "root/surflets")) + (images-dir . ,(absolute-file-name "root/img")) + (port . 8008) + (log-file-name . ,(absolute-file-name "httpd.log")) + (requests . 5))) - (define (normalize-options) - (set! htdocs-dir (absolute-file-name htdocs-dir)) - (set! images-dir (absolute-file-name images-dir)) - (set! log-file-name (absolute-file-name log-file-name)) -; (set! cgi-bin-dir (absolute-file-name cgi-bin-dir)) - (set! port (string->number port)) - (set! surflet-dir (absolute-file-name surflet-dir)) - (set! simultaneous-requests (string->number simultaneous-requests))) + (define (raise-usage-error msg . info) + (display msg (current-error-port)) + (display " --- " (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 get-options - (let* ((unknown-option-error - (lambda (option) - (format (error-output-port) - "unknown option `~A'~%try `surflet-server --help'~%" - option) - (exit 1))) - (missing-argument-error - (lambda (option) - (format (error-output-port) - "option `~A' requires an argument~%try `surflet-server --help'~%" - option) - (exit 1)))) - (lambda (options) - (let loop ((options options)) - (if (null? options) - (normalize-options) - (cond - ((string=? (car options) "-h") - (if (null? (cdr options)) - (missing-argument-error (car options)) - (set! htdocs-dir (cadr options))) - (loop (cddr options))) - ((string=? (car options) "-i") - (if (null? (cdr options)) - (missing-argument-error (car options)) - (set! images-dir (cadr options))) - (loop (cddr options))) - ((string=? (car options) "-c") - (format (error-output-port) - "This is the SUrflet server. It does not support cgi.~%") -; (if (null? (cdr options)) -; (missing-argument-error (car options)) -; (set! cgi-bin-dir (cadr options))) - (loop (cddr options))) - ((string=? (car options) "-p") - (if (null? (cdr options)) - (missing-argument-error (car options)) - (set! port (cadr options))) - (loop (cddr options))) - ((string=? (car options) "-l") - (if (null? (cdr options)) - (missing-argument-error (car options)) - (set! log-file-name (cadr options))) - (loop (cddr options))) - ((string=? (car options) "-s") - (if (null? (cdr options)) - (missing-argument-error (car options)) - (set! surflet-dir (cadr options))) - (loop (cddr options))) - ((string=? (car options) "-r") - (if (null? (cdr options)) - (missing-argument-error (car options)) - (set! simultaneous-requests (cadr options))) - (loop (cddr options))) - ((string=? (car options) "--help") - (display (usage)) - (exit 0)) - ((string=? (car options) "--dump") - (let ((image-name (if (null? (cdr options)) - "surflet-server" - (cadr options)))) - (dump-scsh-program main image-name)) - (exit 0)) - (else - (unknown-option-error (car options))))))))) + (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-option-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-option-proc 'htdocs-dir))) + (surflet-dir-option + (option '(#\s "surflet-dir") #t #f + (absolute-file-option-proc 'surflet-dir))) + (images-dir-option + (option '(#\i "images-dir") #t #f + (absolute-file-option-proc 'images-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-option-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 surflet-dir-option + images-dir-option port-option + log-file-name-option requests-option + help-option) + (lambda (op name arg ops) + (raise-usage-error + "Unknown command line argument: " op)) + cons + '())))) + + (define (make-options-from-args cmd-line-args) + (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 (server . args) (if (pair? args) @@ -145,15 +138,13 @@ exec scsh -lel sunet-2.1/load.scm -lel ssax/load.scm -dm -o surflet-server -e ma (define (main args) (with-cwd - (file-name-directory (car (command-line))) - (init) - (format #t "reading options: ~s~%" (cdr args)) - (get-options (cdr args)) - (cond ((zero? (user-uid)) - (set-gid (->gid "nobody")) - (set-uid (->uid "nobody")))) + (file-name-directory (car (command-line))) + (let ((options (make-options-from-args (cdr args)))) + (cond ((zero? (user-uid)) + (set-gid (->gid "nobody")) + (set-uid (->uid "nobody")))) - (format #t "Going to run SUrflet server with: + (format #t "Going to run SUrflet server with: htdocs-dir: ~a surflet-dir: ~a images-dir: ~a @@ -164,46 +155,44 @@ exec scsh -lel sunet-2.1/load.scm -lel ssax/load.scm -dm -o surflet-server -e ma NOTE: This is the SUrflet server. It does not support cgi. " - htdocs-dir - surflet-dir - images-dir - port - log-file-name - simultaneous-requests) + (lookup-option options 'htdocs-dir) + (lookup-option options 'surflet-dir) + (lookup-option options 'images-dir) + (lookup-option options 'port) + (lookup-option options 'log-file-name) + (lookup-option options 'requests)) - (httpd (make-httpd-options - with-port port - with-root-directory (cwd) - with-simultaneous-requests simultaneous-requests - with-syslog? #t - with-log-file log-file-name - ;; The following settings are made to avoid dns lookups. - with-reported-port port - with-fqdn "localhost" - with-resolve-ips? #f - with-request-handler - (alist-path-dispatcher - (list (cons "h" (home-dir-handler "public_html")) -; (cons "seval" seval-handler) -; (cons "man" (rman-handler #f "man?%s(%s)" -; "Generated by rman-gateway")) -; (cons "info" (info-handler #f #f #f -; "Generated by info-gateway")) -; (cons "cgi-bin" (cgi-handler cgi-bin-dir)) - (cons "source" (rooted-file-or-directory-handler - surflet-dir - (with-file-name->content-type - (lambda (file-name) - (if (string-ci=? (file-name-extension file-name) - ".scm") - "text/plain")) - (make-file-directory-options)))) - (cons "img" (rooted-file-handler images-dir)) - (cons "surflet" (surflet-handler - (with-surflet-path surflet-dir)))) - (rooted-file-or-directory-handler htdocs-dir)))) - )) -)) + (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) + ;; 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 "h" (home-dir-handler "public_html")) + (cons "source" (rooted-file-or-directory-handler + (lookup-option options 'surflet-dir) + (with-file-name->content-type + (lambda (file-name) + (if (string-ci=? + (file-name-extension file-name) ".scm") + "text/plain")) + (make-file-directory-options)))) + (cons "img" (rooted-file-handler + (lookup-option options 'images-dir))) + (cons "surflet" (surflet-handler + (with-surflet-path + (lookup-option options 'surflet-dir))))) + (rooted-file-or-directory-handler + (lookup-option options 'htdocs-dir)))))))) + )) ;; EOF ;;; Local Variables: