+ Use SRFI-37 (arg-fold) for parsing command-line-arguments
This commit is contained in:
eknauel
parent
2b27ee6569
commit
b7314f87f1
|
|
@ -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'~%"
|
|
||||||
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
|
(cond
|
||||||
((string=? (car options) "-h")
|
((not arg)
|
||||||
(if (null? (cdr options))
|
(raise-usage-error "Option requires a number" name arg))
|
||||||
(missing-argument-error (car options))
|
((string->number arg)
|
||||||
(set! htdocs-dir (cadr options)))
|
=> (lambda (n) (cons (cons alist-key n) ops)))
|
||||||
(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
|
(else
|
||||||
(unknown-option-error (car options)))))))))
|
(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)
|
(define (server . args)
|
||||||
(if (pair? args)
|
(if (pair? args)
|
||||||
|
|
@ -146,9 +139,7 @@ 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))
|
|
||||||
(get-options (cdr args))
|
|
||||||
(cond ((zero? (user-uid))
|
(cond ((zero? (user-uid))
|
||||||
(set-gid (->gid "nobody"))
|
(set-gid (->gid "nobody"))
|
||||||
(set-uid (->uid "nobody"))))
|
(set-uid (->uid "nobody"))))
|
||||||
|
|
@ -164,45 +155,43 @@ 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-port (lookup-option options 'port)
|
||||||
with-root-directory (cwd)
|
with-root-directory (cwd)
|
||||||
with-simultaneous-requests simultaneous-requests
|
with-simultaneous-requests (lookup-option options 'requests)
|
||||||
with-syslog? #t
|
with-syslog? #t
|
||||||
with-log-file log-file-name
|
with-log-file (lookup-option options 'log-file-name)
|
||||||
;; The following settings are made to avoid dns lookups.
|
;; The following settings are made to avoid dns lookups.
|
||||||
with-reported-port port
|
with-reported-port (lookup-option options 'port)
|
||||||
with-fqdn "localhost"
|
with-fqdn "localhost"
|
||||||
with-resolve-ips? #f
|
with-resolve-ips? #f
|
||||||
with-request-handler
|
with-request-handler
|
||||||
(alist-path-dispatcher
|
(alist-path-dispatcher
|
||||||
(list (cons "h" (home-dir-handler "public_html"))
|
(list
|
||||||
; (cons "seval" seval-handler)
|
(cons "h" (home-dir-handler "public_html"))
|
||||||
; (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
|
(cons "source" (rooted-file-or-directory-handler
|
||||||
surflet-dir
|
(lookup-option options 'surflet-dir)
|
||||||
(with-file-name->content-type
|
(with-file-name->content-type
|
||||||
(lambda (file-name)
|
(lambda (file-name)
|
||||||
(if (string-ci=? (file-name-extension file-name)
|
(if (string-ci=?
|
||||||
".scm")
|
(file-name-extension file-name) ".scm")
|
||||||
"text/plain"))
|
"text/plain"))
|
||||||
(make-file-directory-options))))
|
(make-file-directory-options))))
|
||||||
(cons "img" (rooted-file-handler images-dir))
|
(cons "img" (rooted-file-handler
|
||||||
|
(lookup-option options 'images-dir)))
|
||||||
(cons "surflet" (surflet-handler
|
(cons "surflet" (surflet-handler
|
||||||
(with-surflet-path surflet-dir))))
|
(with-surflet-path
|
||||||
(rooted-file-or-directory-handler htdocs-dir))))
|
(lookup-option options 'surflet-dir)))))
|
||||||
))
|
(rooted-file-or-directory-handler
|
||||||
|
(lookup-option options 'htdocs-dir))))))))
|
||||||
))
|
))
|
||||||
;; EOF
|
;; EOF
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue