sunet/start-web-server

#!/bin/sh
echo "Loading..."
exec scsh +lpsd -ll packages.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
        scheme-with-scsh)          
                         
  (begin
    
    (define (usage)
      (format #f 
"Usage: start-web-server [-h htdocs-dir] [-c cgi-bin-dir] [-p port]
                        [-l log-file-name] [--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)
 --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 (init)
      (set! htdocs-dir "web-server/root/htdocs")
      (set! cgi-bin-dir "web-server/root/cgi-bin")
      (set! port "8080")
      (set! log-file-name "web-server/httpd.log")
      (set! root "web-server/root"))

    (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 (become-nobody-if-root)
      (cond ((zero? (user-uid))
	     (set-gid (->gid "nobody"))
	     (set-uid (->uid "nobody")))))
    
    (define (main args)
      (init)
      (format #t "reading options: ~s~%" (cdr args))
      (get-options (cdr args))

      (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)

      (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)))
	       (tilde-home-dir-handler "public_html"
				       (rooted-file-or-directory-handler 
					htdocs-dir))))))
))
;; EOF

;;; Local Variables:
;;; mode:scheme
;;; End: