scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

+ Use SRFI-37 (arg-fold) for parsing command-line-arguments

This commit is contained in:
eknauel 2004-02-09 08:09:35 +00:00
parent 2b27ee6569
commit b7314f87f1
1 changed files with 135 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

279
start-surflet-server
View File

@ -19,15 +19,19 @@ exec scsh -lel sunet-2.1/load.scm -lel ssax/load.scm -dm -o surflet-server -e ma
surflet-handler/options surflet-handler/options
let-opt let-opt
scsh scsh
scheme) scheme
srfi-37
signals)
(begin (begin
(define (usage) (define (usage)
(format #f (format #f
"Usage: start-surflet-server [-h htdocs-dir] [-s surflet-dir] [-i images-dir] "Usage: start-surflet-server
[-p port] [-l log-file-name] [-h DIR | --htdocs-dir=DIR] [-s DIR | --surflet-dir=DIR]
[-r requests] [--help] [-i DIR | --images-dir=DIR] [-p NUM | --port=NUM]
[-l FILE | --log-file-name=FILE] [-r NUM | --requests=NUM]
[--help]
with with
htdocs-dir directory of html files (default: ./web-server/root/htdocs) 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) requests maximal amount of simultaneous requests (default 5)
--help show this help --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 (display-usage)
(define images-dir #f) (display (usage) (current-error-port))
; (define cgi-bin-dir #f) (exit 1))1
(define port #f)
(define log-file-name #f)
(define root #f)
(define surflet-dir #f)
(define simultaneous-requests #f)
(define (init) (define default-options
(set! htdocs-dir "root/htdocs") `((htdocs-dir . ,(absolute-file-name "root/htdocs"))
(set! images-dir "root/img") (surflet-dir . ,(absolute-file-name "root/surflets"))
; (set! cgi-bin-dir "./web-server/root/cgi-bin") (images-dir . ,(absolute-file-name "root/img"))
(set! port "8008") (port . 8008)
(set! log-file-name "httpd.log") (log-file-name . ,(absolute-file-name "httpd.log"))
(set! root "root") (requests . 5)))
(set! surflet-dir "root/surflets")
(set! simultaneous-requests "5"))
(define (normalize-options) (define (raise-usage-error msg . info)
(set! htdocs-dir (absolute-file-name htdocs-dir)) (display msg (current-error-port))
(set! images-dir (absolute-file-name images-dir)) (display " --- " (current-error-port))
(set! log-file-name (absolute-file-name log-file-name)) (for-each
; (set! cgi-bin-dir (absolute-file-name cgi-bin-dir)) (lambda (i)
(set! port (string->number port)) (display i (current-error-port))
(set! surflet-dir (absolute-file-name surflet-dir)) (display " " (current-error-port)))
(set! simultaneous-requests (string->number simultaneous-requests))) info)
(display "\n" (current-error-port))
(exit 1))
(define get-options (define (parse-arguments arg-list)
(let* ((unknown-option-error (let ((number-option-proc
(lambda (option) (lambda (alist-key)
(format (error-output-port) (lambda (option name arg ops)
"unknown option `~A'~%try `surflet-server --help'~%" (cond
option) ((not arg)
(exit 1))) (raise-usage-error "Option requires a number" name arg))
(missing-argument-error ((string->number arg)
(lambda (option) => (lambda (n) (cons (cons alist-key n) ops)))
(format (error-output-port) (else
"option `~A' requires an argument~%try `surflet-server --help'~%" (raise-usage-error "Not a number" arg))))))
option) (absolute-file-option-proc
(exit 1)))) (lambda (alist-key)
(lambda (options) (lambda (option name arg ops)
(let loop ((options options)) (cons (cons alist-key
(if (null? options) (absolute-file-name arg)) ops)))))
(normalize-options)
(cond (let ((htdocs-dir-option
((string=? (car options) "-h") (option '(#\h "htdocs-dir") #t #f
(if (null? (cdr options)) (absolute-file-option-proc 'htdocs-dir)))
(missing-argument-error (car options)) (surflet-dir-option
(set! htdocs-dir (cadr options))) (option '(#\s "surflet-dir") #t #f
(loop (cddr options))) (absolute-file-option-proc 'surflet-dir)))
((string=? (car options) "-i") (images-dir-option
(if (null? (cdr options)) (option '(#\i "images-dir") #t #f
(missing-argument-error (car options)) (absolute-file-option-proc 'images-dir)))
(set! images-dir (cadr options))) (port-option
(loop (cddr options))) (option '(#\p "port") #t #f
((string=? (car options) "-c") (number-option-proc 'port)))
(format (error-output-port) (log-file-name-option
"This is the SUrflet server. It does not support cgi.~%") (option '(#\l "log-file-name") #t #f
; (if (null? (cdr options)) (absolute-file-option-proc 'log-file-name)))
; (missing-argument-error (car options)) (requests-option
; (set! cgi-bin-dir (cadr options))) (option '(#\r "requests") #t #f
(loop (cddr options))) (number-option-proc 'requests)))
((string=? (car options) "-p") (help-option
(if (null? (cdr options)) (option '(#f "help") #f #f
(missing-argument-error (car options)) (lambda (option name arg ops)
(set! port (cadr options))) (display-usage)))))
(loop (cddr options))) (args-fold arg-list
((string=? (car options) "-l") (list htdocs-dir-option surflet-dir-option
(if (null? (cdr options)) images-dir-option port-option
(missing-argument-error (car options)) log-file-name-option requests-option
(set! log-file-name (cadr options))) help-option)
(loop (cddr options))) (lambda (op name arg ops)
((string=? (car options) "-s") (raise-usage-error
(if (null? (cdr options)) "Unknown command line argument: " op))
(missing-argument-error (car options)) cons
(set! surflet-dir (cadr options))) '()))))
(loop (cddr options)))
((string=? (car options) "-r") (define (make-options-from-args cmd-line-args)
(if (null? (cdr options)) (let ((given (parse-arguments cmd-line-args)))
(missing-argument-error (car options)) (map (lambda (p)
(set! simultaneous-requests (cadr options))) (or (assoc (car p) given) p))
(loop (cddr options))) default-options)))
((string=? (car options) "--help")
(display (usage)) (define (lookup-option alist option)
(exit 0)) (cond
((string=? (car options) "--dump") ((assoc option alist)
(let ((image-name (if (null? (cdr options)) => cdr)
"surflet-server" (else
(cadr options)))) (error "Internal error, option not found" option alist))))
(dump-scsh-program main image-name))
(exit 0))
(else
(unknown-option-error (car options)))))))))
(define (server . args) (define (server . args)
(if (pair? 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) (define (main args)
(with-cwd (with-cwd
(file-name-directory (car (command-line))) (file-name-directory (car (command-line)))
(init) (let ((options (make-options-from-args (cdr args))))
(format #t "reading options: ~s~%" (cdr args)) (cond ((zero? (user-uid))
(get-options (cdr args)) (set-gid (->gid "nobody"))
(cond ((zero? (user-uid)) (set-uid (->uid "nobody"))))
(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 htdocs-dir: ~a
surflet-dir: ~a surflet-dir: ~a
images-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. NOTE: This is the SUrflet server. It does not support cgi.
" "
htdocs-dir (lookup-option options 'htdocs-dir)
surflet-dir (lookup-option options 'surflet-dir)
images-dir (lookup-option options 'images-dir)
port (lookup-option options 'port)
log-file-name (lookup-option options 'log-file-name)
simultaneous-requests) (lookup-option options 'requests))
(httpd (make-httpd-options (httpd
with-port port (make-httpd-options
with-root-directory (cwd) with-port (lookup-option options 'port)
with-simultaneous-requests simultaneous-requests with-root-directory (cwd)
with-syslog? #t with-simultaneous-requests (lookup-option options 'requests)
with-log-file log-file-name with-syslog? #t
;; The following settings are made to avoid dns lookups. with-log-file (lookup-option options 'log-file-name)
with-reported-port port ;; The following settings are made to avoid dns lookups.
with-fqdn "localhost" with-reported-port (lookup-option options 'port)
with-resolve-ips? #f with-fqdn "localhost"
with-request-handler with-resolve-ips? #f
(alist-path-dispatcher with-request-handler
(list (cons "h" (home-dir-handler "public_html")) (alist-path-dispatcher
; (cons "seval" seval-handler) (list
; (cons "man" (rman-handler #f "man?%s(%s)" (cons "h" (home-dir-handler "public_html"))
; "Generated by rman-gateway")) (cons "source" (rooted-file-or-directory-handler
; (cons "info" (info-handler #f #f #f (lookup-option options 'surflet-dir)
; "Generated by info-gateway")) (with-file-name->content-type
; (cons "cgi-bin" (cgi-handler cgi-bin-dir)) (lambda (file-name)
(cons "source" (rooted-file-or-directory-handler (if (string-ci=?
surflet-dir (file-name-extension file-name) ".scm")
(with-file-name->content-type "text/plain"))
(lambda (file-name) (make-file-directory-options))))
(if (string-ci=? (file-name-extension file-name) (cons "img" (rooted-file-handler
".scm") (lookup-option options 'images-dir)))
"text/plain")) (cons "surflet" (surflet-handler
(make-file-directory-options)))) (with-surflet-path
(cons "img" (rooted-file-handler images-dir)) (lookup-option options 'surflet-dir)))))
(cons "surflet" (surflet-handler (rooted-file-or-directory-handler
(with-surflet-path surflet-dir)))) (lookup-option options 'htdocs-dir))))))))
(rooted-file-or-directory-handler htdocs-dir)))) ))
))
))
;; EOF ;; EOF
;;; Local Variables: ;;; Local Variables: