Use args-fold (SRFI-37) for parsing command-line arguments
This commit is contained in:
eknauel
parent
7db04b74e2
commit
704ffae307
|
|
@ -15,14 +15,18 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
|
|||
httpd-info-gateway
|
||||
let-opt
|
||||
scsh
|
||||
scheme)
|
||||
|
||||
scheme
|
||||
srfi-37)
|
||||
|
||||
(begin
|
||||
|
||||
(define (usage)
|
||||
(format #f
|
||||
"Usage: start-extended-web-server [-h htdocs-dir] [-c cgi-bin-dir] [-p port]
|
||||
[-l log-file-name] [-r requests] [--help]
|
||||
"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: web-server/root/htdocs)
|
||||
|
|
@ -32,96 +36,97 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
|
|||
(default: web-server/httpd.log)
|
||||
requests maximal amount of simultaneous requests (default 5)
|
||||
--help show this help
|
||||
"
|
||||
))
|
||||
"))
|
||||
|
||||
(define htdocs-dir #f)
|
||||
(define cgi-bin-dir #f)
|
||||
(define port #f)
|
||||
(define log-file-name #f)
|
||||
(define root #f)
|
||||
(define simultaneous-requests #f)
|
||||
(define (display-usage)
|
||||
(display (usage) (current-error-port))
|
||||
(exit 1))
|
||||
|
||||
(define (init)
|
||||
(set! htdocs-dir "root/htdocs")
|
||||
(set! cgi-bin-dir "root/cgi-bin")
|
||||
(set! port "8080")
|
||||
(set! log-file-name "httpd.log")
|
||||
(set! root "root")
|
||||
(set! simultaneous-requests "5"))
|
||||
(define default-options
|
||||
`((htdocs-dir . ,(absolute-file-name "web-server/root/htdocs"))
|
||||
(cgi-bin-dir . ,(absolute-file-name "web-server/root/cgi-bin"))
|
||||
(port . 8080)
|
||||
(log-file-name . ,(absolute-file-name "web-server/httpd.log"))
|
||||
(requests . 5)))
|
||||
|
||||
(define get-options
|
||||
(let* ((unknown-option-error
|
||||
(lambda (option)
|
||||
(format (error-output-port)
|
||||
"unknown option `~A'~%try `start-web-server --help'~%"
|
||||
option)
|
||||
(exit 1)))
|
||||
(missing-argument-error
|
||||
(lambda (option)
|
||||
(format (error-output-port)
|
||||
"option `~A' requires an argument~%try `start-web-server --help'~%"
|
||||
option)
|
||||
(exit 1))))
|
||||
(lambda (options)
|
||||
(let loop ((options options))
|
||||
(if (null? options)
|
||||
(begin
|
||||
(set! htdocs-dir (absolute-file-name htdocs-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! simultaneous-requests (string->number simultaneous-requests)))
|
||||
(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) "-c")
|
||||
(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) "-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))
|
||||
"server"
|
||||
(cadr options))))
|
||||
(dump-scsh-program main image-name))
|
||||
(exit 0))
|
||||
(else
|
||||
(unknown-option-error (car options)))))))))
|
||||
(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)
|
||||
(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 (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 Webserver with:
|
||||
(format #t "Going to run Webserver with:
|
||||
htdocs-dir: ~a
|
||||
cgi-bin-dir: ~a
|
||||
port: ~a
|
||||
|
|
@ -129,34 +134,36 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
|
|||
a maximum of ~a simultaneous requests, syslogging activated,
|
||||
and home-dir-handler (public_html) activated.
|
||||
"
|
||||
htdocs-dir
|
||||
cgi-bin-dir
|
||||
port
|
||||
log-file-name
|
||||
simultaneous-requests)
|
||||
(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 port
|
||||
with-root-directory (cwd)
|
||||
with-simultaneous-requests simultaneous-requests
|
||||
with-syslog? #t
|
||||
with-log-file log-file-name
|
||||
with-request-handler
|
||||
(alist-path-dispatcher
|
||||
(list (cons "h" (home-dir-handler "public_html"))
|
||||
(cons "seval" seval-handler)
|
||||
;; You may want to adapt this to your site.
|
||||
(cons "man" (rman-handler 'man
|
||||
'nroff
|
||||
"/usr/bin/rman"
|
||||
"/usr/bin/zcat"
|
||||
#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)))
|
||||
(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)
|
||||
with-request-handler
|
||||
(alist-path-dispatcher
|
||||
(list (cons "h" (home-dir-handler "public_html"))
|
||||
(cons "seval" seval-handler)
|
||||
;; You may want to adapt this to your site.
|
||||
(cons "man" (rman-handler 'man
|
||||
'nroff
|
||||
"/usr/bin/rman"
|
||||
"/usr/bin/zcat"
|
||||
#f "man?%s(%s)"
|
||||
"Generated by rman-gateway"))
|
||||
(cons "info" (info-handler #f #f #f
|
||||
"Generated by info-gateway"))
|
||||
(cons "cgi-bin" (cgi-handler
|
||||
(lookup-option options 'cgi-bin-dir))))
|
||||
(rooted-file-or-directory-handler
|
||||
(lookup-option options 'htdocs-dir))))))))
|
||||
))
|
||||
|
||||
;; EOF
|
||||
|
||||
|
|
|
|||
200
start-web-server
200
start-web-server
|
|
@ -11,92 +11,108 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
|
|||
httpd-file-directory-handlers
|
||||
httpd-cgi-handlers
|
||||
httpd-seval-handlers
|
||||
scheme-with-scsh)
|
||||
scheme-with-scsh
|
||||
srfi-37)
|
||||
|
||||
(begin
|
||||
|
||||
(define (usage)
|
||||
(format #f
|
||||
"Usage: start-web-server [-h htdocs-dir] [-c cgi-bin-dir] [-p port]
|
||||
[-l log-file-name] [--help]
|
||||
"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: web-server/root/htdocs)
|
||||
cgi-bin-dir directory of cgi files (default: web-server/root/cgi-bin)
|
||||
port port server is listening to (default: 8080)
|
||||
log-file-name directory where to store the logfile in CLF
|
||||
(default: web-server/httpd.log)
|
||||
(default: web-server/httpd.log)
|
||||
--help show this help
|
||||
"
|
||||
))
|
||||
"))
|
||||
|
||||
(define htdocs-dir #f)
|
||||
(define cgi-bin-dir #f)
|
||||
(define port #f)
|
||||
(define log-file-name #f)
|
||||
(define root #f)
|
||||
(define (display-usage)
|
||||
(display (usage) (current-error-port))
|
||||
(exit 1))
|
||||
|
||||
(define (init)
|
||||
(set! htdocs-dir "root/htdocs")
|
||||
(set! cgi-bin-dir "root/cgi-bin")
|
||||
(set! port "8080")
|
||||
(set! log-file-name "httpd.log")
|
||||
(set! root "root"))
|
||||
(define default-options
|
||||
`((htdocs-dir . ,(absolute-file-name "web-server/root/htdocs"))
|
||||
(cgi-bin-dir . ,(absolute-file-name "web-server/root/cgi-bin"))
|
||||
(port . 8080)
|
||||
(log-file-name . ,(absolute-file-name "web-server/httpd.log"))
|
||||
(requests . 5)))
|
||||
|
||||
(define get-options
|
||||
(let* ((unknown-option-error
|
||||
(lambda (option)
|
||||
(format (error-output-port)
|
||||
"unknown option `~A'~%try `start-web-server --help'~%"
|
||||
option)
|
||||
(exit 1)))
|
||||
(missing-argument-error
|
||||
(lambda (option)
|
||||
(format (error-output-port)
|
||||
"option `~A' requires an argument~%try `start-web-server --help'~%"
|
||||
option)
|
||||
(exit 1))))
|
||||
(lambda (options)
|
||||
(let loop ((options options))
|
||||
(if (null? options)
|
||||
(begin
|
||||
(set! htdocs-dir (absolute-file-name htdocs-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)))
|
||||
(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) "-c")
|
||||
(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) "--help")
|
||||
(display (usage))
|
||||
(exit 0))
|
||||
((string=? (car options) "--dump")
|
||||
(let ((image-name (if (null? (cdr options))
|
||||
"web-server"
|
||||
(cadr options))))
|
||||
(dump-scsh-program main image-name))
|
||||
(exit 0))
|
||||
(else
|
||||
(unknown-option-error (car options)))))))))
|
||||
(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)
|
||||
(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"))
|
||||
|
|
@ -104,37 +120,35 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
|
|||
|
||||
(define (main args)
|
||||
(with-cwd
|
||||
(file-name-directory (car (command-line)))
|
||||
(init)
|
||||
(format #t "reading options: ~s~%" (cdr args))
|
||||
(get-options (cdr args))
|
||||
(file-name-directory (car (command-line)))
|
||||
(let ((options (make-options-from-args (cdr args))))
|
||||
|
||||
(format #t "Going to run Webserver with:
|
||||
(format #t "Going to run Webserver with:
|
||||
htdocs-dir: ~a
|
||||
cgi-bin-dir: ~a
|
||||
port: ~a
|
||||
log-file-name: ~a
|
||||
syslogging activated.
|
||||
"
|
||||
htdocs-dir
|
||||
cgi-bin-dir
|
||||
port
|
||||
log-file-name)
|
||||
(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 port
|
||||
with-root-directory (cwd)
|
||||
with-syslog? #t
|
||||
with-log-file log-file-name
|
||||
with-post-bind-thunk become-nobody-if-root
|
||||
with-request-handler
|
||||
(alist-path-dispatcher
|
||||
(list (cons "cgi-bin" (cgi-handler cgi-bin-dir))
|
||||
(cons "seval" seval-handler))
|
||||
(tilde-home-dir-handler "public_html"
|
||||
(rooted-file-or-directory-handler
|
||||
htdocs-dir)))))))
|
||||
))
|
||||
(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
|
||||
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:
|
||||
|
|
|
|||
Loading…
Reference in New Issue