sunet/web-server/start-extended-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
	httpd-rman-gateway
	httpd-info-gateway
	let-opt
        scsh             
        scheme
	srfi-37)

  (begin
    
    (define (usage)
      (format #f 
"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: root/htdocs)
 cgi-bin-dir    directory of cgi files  (default: 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)
 requests       maximal amount of simultaneous requests (default 5)
 --help         show this help
"))

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

    (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 default-options)
      (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* ((default-options
                   `((htdocs-dir	. ,(absolute-file-name "root/htdocs"))
                     (cgi-bin-dir	. ,(absolute-file-name "root/cgi-bin"))
                     (port		. 8080)
                     (log-file-name	. "/tmp/httpd.log")
                     (requests	. 5)))
                 (options (make-options-from-args (cdr args) default-options)))

	  (format #t "Going to run Webserver with:
 htdocs-dir:    ~a
 cgi-bin-dir:   ~a
 port:          ~a
 log-file-name: ~a
 a maximum of ~a simultaneous requests, syslogging activated, 
 and home-dir-handler (public_html) activated.
"
		  (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			(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-post-bind-thunk          become-nobody-if-root
		  with-request-handler 
		  (alist-path-dispatcher
		   (list (cons "seval" seval-handler) 
			 ;; You may want to adapt this to your site.
			 ;; call like http://localhost:8080/man/man?ssh(1)
			 (cons "man" (rman-handler 'man
						   'nroff
						   "/usr/X11R6/bin/rman"
						   "/usr/bin/zcat"
						   #f "man?%s(%s)" 
						   "Generated by rman-gateway"))
			 ;; call like http://localhost:8080/info/info?(slib.info)Top
			 ;; note: can only handle not-gzipped info files
			 (cons "info" (info-handler #f #f #f
						    "Generated by info-gateway"))
			 (cons "cgi-bin" (cgi-handler 
					  (lookup-option options 'cgi-bin-dir))))
                   (tilde-home-dir-handler "public_html"
                                           (rooted-file-or-directory-handler 
                                            (lookup-option options htdocs-dir)))))))))
      ))

;; EOF

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