sunet/start-web-server

#!/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
        scheme-with-scsh
	srfi-37)
                         
  (begin
    
    (define (usage)
      (format #f 
"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: /tmp/httpd.log)
 --help         show this help
"))

    (define (display-usage)
      (display (usage) (current-error-port))
      (exit 1))

    (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	. "/tmp/httpd.log")
	(requests	. 5)))

    (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"))
	     (set-uid (->uid "nobody")))))
    
    (define (main args)
      (with-cwd 
	  (file-name-directory (car args))
	(let ((options (make-options-from-args (cdr args))))

	  (format #t "Going to run Webserver with:
 htdocs-dir:    ~a
 cgi-bin-dir:   ~a
 port:          ~a
 log-file-name: ~a
 syslogging activated.
"
		  (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			(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:
;;; mode:scheme
;;; End: