Be more flexible with paths; use $SUNETHOME and $SSAXPATH if set or
reasonable default values if not. In particular, work around the dependency of config on cwd.
This commit is contained in:
interp
parent
1abbed29f0
commit
7dde62cd1a
|
|
@ -1,11 +1,37 @@
|
|||
; reads package description in the right order
|
||||
; in the end, the server can be started via (main '())
|
||||
; in the end, the server can be started via (server)
|
||||
|
||||
(batch 'on)
|
||||
(config)
|
||||
(load "/home/andreas/hiwi/sunet/packages.scm")
|
||||
(load "/home/andreas/hiwi/sunet/SSAX/lib/packages.scm")
|
||||
(load "/home/andreas/hiwi/sunet/httpd/servlets/packages.scm")
|
||||
(load "/home/andreas/hiwi/sunet/httpd/servlets/start-servlet-server")
|
||||
(define *ASSUMED-SUNET-HOME*
|
||||
(in 'scsh '(run (match:substring
|
||||
(regexp-search (rx (submatch (* any) "sunet")) (cwd))
|
||||
1))))
|
||||
(define *SUNET-PACKAGE*
|
||||
(in 'scsh `(run (string-append
|
||||
(or (getenv "SUNETHOME")
|
||||
,*ASSUMED-SUNET-HOME*)
|
||||
"/packages.scm"))))
|
||||
(define *SSAX-PACKAGE*
|
||||
(in 'scsh `(run (string-append
|
||||
(or (getenv "SSAXPATH")
|
||||
(string-append ,*ASSUMED-SUNET-HOME* "/SSAX"))
|
||||
"/lib/packages.scm"))))
|
||||
(define *SERLVET-PACKAGE*
|
||||
(in 'scsh `(run (string-append
|
||||
(or (getenv "SUNETHOME")
|
||||
,*ASSUMED-SUNET-HOME*)
|
||||
"/httpd/servlets/packages.scm"))))
|
||||
(define *SERVLET-SERVER*
|
||||
(in 'scsh `(run (string-append
|
||||
(or (getenv "SUNETHOME")
|
||||
,*ASSUMED-SUNET-HOME*)
|
||||
"/httpd/servlets/start-servlet-server"))))
|
||||
(config `(load ,*SUNET-PACKAGE*))
|
||||
(config `(load ,*SSAX-PACKAGE*))
|
||||
(config `(load ,*SERLVET-PACKAGE*))
|
||||
(config `(load ,*SERVLET-SERVER*))
|
||||
(user)
|
||||
(open 'servlet-server)
|
||||
(batch 'off)
|
||||
(batch 'off)
|
||||
(in 'scsh '(run (display "type (server) to start the server\n")))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,17 @@
|
|||
#!/bin/sh
|
||||
echo "Loading..."
|
||||
exec scsh -lm ${SUNETHOME:-../..}/packages.scm -lm ${SUNETHOME:-../..}/httpd/servlets/packages.scm -lm ${SSAXPATH:-${SUNETHOME:-../..}/SSAX}/lib/packages.scm -dm -o servlet-server -e main -s "$0" "$@"
|
||||
fullpath=`which $0`
|
||||
# $sunet is either $SUNETHOME or created out of fullpath
|
||||
# Kind of a hack, I know.
|
||||
sunet=${SUNETHOME:-`dirname $fullpath`/../..}
|
||||
ssax=${SSAXPATH:-$sunet/SSAX} # path to SSAX
|
||||
|
||||
exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/servlets/packages.scm -dm -o servlet-server -e main -s "$0" "$@"
|
||||
!#
|
||||
|
||||
(define-structure servlet-server
|
||||
(export main)
|
||||
(export main ; sh jump entry point
|
||||
server) ; scsh entry point
|
||||
(open httpd-core
|
||||
httpd-make-options
|
||||
httpd-basic-handlers
|
||||
|
|
@ -22,15 +29,15 @@ exec scsh -lm ${SUNETHOME:-../..}/packages.scm -lm ${SUNETHOME:-../..}/httpd/ser
|
|||
|
||||
(define (usage)
|
||||
(format #f
|
||||
"Usage: start-web-server [-h htdocs-dir] [-c cgi-bin-dir] [-p port]
|
||||
"Usage: start-web-server [-h htdocs-dir] [-s servlet-dir] [-p port]
|
||||
[-l log-file-name] [-r requests] [--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)
|
||||
htdocs-dir directory of html files (default: ./web-server/root/htdocs)
|
||||
servlet-dir directory of servlet files (default: ./web-server/root/servlets)
|
||||
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)
|
||||
requests maximal amount of simultaneous requests (default 5)
|
||||
--help show this help
|
||||
|
||||
|
|
@ -39,7 +46,7 @@ exec scsh -lm ${SUNETHOME:-../..}/packages.scm -lm ${SUNETHOME:-../..}/httpd/ser
|
|||
))
|
||||
|
||||
(define htdocs-dir #f)
|
||||
(define cgi-bin-dir #f)
|
||||
; (define cgi-bin-dir #f)
|
||||
(define port #f)
|
||||
(define log-file-name #f)
|
||||
(define root #f)
|
||||
|
|
@ -47,14 +54,22 @@ exec scsh -lm ${SUNETHOME:-../..}/packages.scm -lm ${SUNETHOME:-../..}/httpd/ser
|
|||
(define simultaneous-requests #f)
|
||||
|
||||
(define (init)
|
||||
(set! htdocs-dir "web-server/root/htdocs")
|
||||
(set! cgi-bin-dir "web-server/root/cgi-bin")
|
||||
(set! htdocs-dir "./web-server/root/htdocs")
|
||||
; (set! cgi-bin-dir "./web-server/root/cgi-bin")
|
||||
(set! port "8088")
|
||||
(set! log-file-name "web-server/httpd.log")
|
||||
(set! root "web-server/root")
|
||||
(set! servlet-dir "web-server/root/servlets")
|
||||
(set! log-file-name "./web-server/httpd.log")
|
||||
(set! root "./web-server/root")
|
||||
(set! servlet-dir "./web-server/root/servlets")
|
||||
(set! simultaneous-requests "5"))
|
||||
|
||||
(define (normalize-options)
|
||||
(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! servlet-dir (absolute-file-name servlet-dir))
|
||||
(set! simultaneous-requests (string->number simultaneous-requests)))
|
||||
|
||||
(define get-options
|
||||
(let* ((unknown-option-error
|
||||
(lambda (option)
|
||||
|
|
@ -71,13 +86,7 @@ exec scsh -lm ${SUNETHOME:-../..}/packages.scm -lm ${SUNETHOME:-../..}/httpd/ser
|
|||
(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! servlet-dir (absolute-file-name servlet-dir))
|
||||
(set! simultaneous-requests (string->number simultaneous-requests)))
|
||||
(normalize-options)
|
||||
(cond
|
||||
((string=? (car options) "-h")
|
||||
(if (null? (cdr options))
|
||||
|
|
@ -123,6 +132,10 @@ exec scsh -lm ${SUNETHOME:-../..}/packages.scm -lm ${SUNETHOME:-../..}/httpd/ser
|
|||
(else
|
||||
(unknown-option-error (car options)))))))))
|
||||
|
||||
(define (server . args)
|
||||
(if (pair? args)
|
||||
(main `(main ,@(car args)))
|
||||
(main '(main))))
|
||||
|
||||
(define (main args)
|
||||
(init)
|
||||
|
|
@ -134,7 +147,7 @@ exec scsh -lm ${SUNETHOME:-../..}/packages.scm -lm ${SUNETHOME:-../..}/httpd/ser
|
|||
|
||||
(format #t "Going to run Servlet server with:
|
||||
htdocs-dir: ~a
|
||||
cgi-bin-dir: ~a
|
||||
servlet-dir: ~a
|
||||
port: ~a
|
||||
log-file-name: ~a
|
||||
a maximum of ~a simultaneous requests, syslogging activated,
|
||||
|
|
@ -143,13 +156,13 @@ exec scsh -lm ${SUNETHOME:-../..}/packages.scm -lm ${SUNETHOME:-../..}/httpd/ser
|
|||
NOTE: This is the Servlet server. It does not support cgi.
|
||||
"
|
||||
htdocs-dir
|
||||
cgi-bin-dir
|
||||
servlet-dir
|
||||
port
|
||||
log-file-name
|
||||
simultaneous-requests)
|
||||
|
||||
(httpd (with-port port
|
||||
; (with-root-directory (absolute-file-name "./web-server/root")
|
||||
(with-root-directory (cwd)
|
||||
(with-simultaneous-requests simultaneous-requests
|
||||
(with-syslog? #t
|
||||
(with-logfile log-file-name
|
||||
|
|
@ -163,7 +176,7 @@ exec scsh -lm ${SUNETHOME:-../..}/packages.scm -lm ${SUNETHOME:-../..}/httpd/ser
|
|||
; "Generated by info-gateway"))
|
||||
; (cons "cgi-bin" (cgi-handler cgi-bin-dir))
|
||||
(cons "servlet" (servlet-handler servlet-dir)))
|
||||
(rooted-file-or-directory-handler htdocs-dir)))))))))
|
||||
(rooted-file-or-directory-handler htdocs-dir))))))))))
|
||||
))
|
||||
;; EOF
|
||||
|
||||
|
|
|
|||
|
|
@ -34,14 +34,14 @@
|
|||
(lambda (path req)
|
||||
(if (pair? path) ; need at least one element
|
||||
(let ((request-method (request:method req))
|
||||
(full-path (uri-path-list->path path)))
|
||||
(path-string (uri-path-list->path path)))
|
||||
(cond
|
||||
((string=? full-path "profile") ; triggers profiling
|
||||
((string=? path-string "profile") ; triggers profiling
|
||||
(http-syslog (syslog-level debug)
|
||||
"profiling: triggered in servlet-handler [~a]"
|
||||
(profile-space)) ; PROFILE
|
||||
(make-http-error-response http-status/accepted req "profiled"))
|
||||
((string=? full-path "reset") ; triggers cache clearing
|
||||
((string=? path-string "reset") ; triggers cache clearing
|
||||
(http-syslog (syslog-level debug)
|
||||
"servlet-handler: clearing plugin cache")
|
||||
(reset-plugin-cache!)
|
||||
|
|
@ -52,26 +52,24 @@
|
|||
((or (string=? request-method "GET")
|
||||
; (string=? request-method "POST")) ; do this at later time
|
||||
)
|
||||
(with-cwd
|
||||
servlet-path
|
||||
(if (resume-url? full-path)
|
||||
(resume-url full-path req)
|
||||
(launch-new-instance full-path req))))
|
||||
(if (resume-url? path-string)
|
||||
(resume-url path-string servlet-path req)
|
||||
(launch-new-instance path-string servlet-path req)))
|
||||
(else
|
||||
(make-http-error-response http-status/method-not-allowed req
|
||||
request-method))))
|
||||
(make-http-error-response http-status/bad-request req
|
||||
(format #f "Bad path: ~s" path)))))
|
||||
|
||||
(define (launch-new-instance full-path req)
|
||||
(if (file-not-exists? full-path)
|
||||
(make-http-error-response http-status/not-found req full-path)
|
||||
(define (launch-new-instance path-string servlet-path req)
|
||||
(if (file-not-exists? (absolute-file-name path-string servlet-path))
|
||||
(make-http-error-response http-status/not-found req path-string)
|
||||
(begin
|
||||
(obtain-lock *instance-table-lock*)
|
||||
;; no access to instance table until new instance-id is saved
|
||||
(let ((instance-id (generate-new-table-id *instance-table*)))
|
||||
(table-set! *instance-table* instance-id
|
||||
(make-instance full-path ; used to make
|
||||
(make-instance path-string ; used to make
|
||||
; redirections to origin
|
||||
(make-integer-table) ; continuation table
|
||||
(make-lock) ; continuation table lock
|
||||
|
|
@ -82,23 +80,25 @@
|
|||
(instance-delete! instance-id)
|
||||
(decline))
|
||||
(lambda ()
|
||||
(get-plugin-rt-structure full-path)))))
|
||||
(get-plugin-rt-structure path-string servlet-path)))))
|
||||
(reset
|
||||
(begin
|
||||
(register-session! instance-id 'no-return)
|
||||
(with-names-from-rt-structure
|
||||
plugin plugin-interface
|
||||
(main req)))))))))
|
||||
(with-cwd
|
||||
servlet-path
|
||||
(with-names-from-rt-structure
|
||||
plugin plugin-interface
|
||||
(main req))))))))))
|
||||
|
||||
;; try to get continuation-table and then the continuation
|
||||
(define resume-url
|
||||
(let ((bad-request
|
||||
(lambda (full-path req)
|
||||
(lambda (path-string req)
|
||||
(make-http-error-response
|
||||
http-status/bad-request req
|
||||
(format #f "The servlet does not accept any requests any more or your URL is illformed.<BR>
|
||||
You can try starting at the <A HREF=~a>beginning</a>."
|
||||
(resume-url-servlet-name full-path)))))
|
||||
(resume-url-servlet-name path-string)))))
|
||||
(lookup-continuation-table
|
||||
(lambda (instance continuation-table continuation-id)
|
||||
(let ((continuation-table-lock (instance-continuation-table-lock instance)))
|
||||
|
|
@ -107,22 +107,23 @@ You can try starting at the <A HREF=~a>beginning</a>."
|
|||
(release-lock continuation-table-lock)
|
||||
result)))))
|
||||
|
||||
(lambda (full-path req)
|
||||
(lambda (path-string servlet-path req)
|
||||
(receive (instance-id continuation-id)
|
||||
(resume-url-ids full-path)
|
||||
(resume-url-ids path-string)
|
||||
(let ((instance (instance-lookup instance-id)))
|
||||
(if instance
|
||||
(let* ((continuation-table (instance-continuation-table instance))
|
||||
(resume (lookup-continuation-table instance continuation-table
|
||||
continuation-id)))
|
||||
(if resume
|
||||
(reset
|
||||
(begin
|
||||
(register-session! instance-id 'no-return)
|
||||
; (error "This may never return." ; for debugging
|
||||
(resume req)))
|
||||
(bad-request full-path req)))
|
||||
(bad-request full-path req)))
|
||||
(with-cwd
|
||||
servlet-path
|
||||
(reset
|
||||
(begin
|
||||
(register-session! instance-id 'no-return)
|
||||
(resume req))))
|
||||
(bad-request path-string req)))
|
||||
(bad-request path-string req)))
|
||||
))))
|
||||
|
||||
|
||||
|
|
@ -182,35 +183,37 @@ You can try starting at the <A HREF=~a>beginning</a>."
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; PLUGINs CACHE
|
||||
(define *plugin-table* (make-string-table)) ; full-path is index
|
||||
(define *plugin-table* (make-string-table)) ; path-string is index
|
||||
(define *plugin-table-lock* (make-lock))
|
||||
|
||||
;; PLUGIN-NAME is like "news-dir/latest-news.scm"
|
||||
(define (get-plugin-rt-structure plugin-name)
|
||||
(let ((load-plugin
|
||||
(lambda ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(release-lock *plugin-table-lock*)
|
||||
(decline))
|
||||
(lambda ()
|
||||
;; load-config-file does not care about cwd(?)
|
||||
;; --> absolute file name needed
|
||||
(load-config-file (absolute-file-name plugin-name))
|
||||
;; plugin-structure to load must be named "plugin"
|
||||
(let ((plugin-structure (reify-structure 'plugin)))
|
||||
(load-structure plugin-structure)
|
||||
(table-set! *plugin-table* plugin-name
|
||||
(cons plugin-structure
|
||||
(file-last-mod plugin-name)))
|
||||
;; only now the lock may be released
|
||||
(release-lock *plugin-table-lock*)
|
||||
plugin-structure))))))
|
||||
(define (get-plugin-rt-structure plugin-name directory)
|
||||
(let* ((full-plugin-name (absolute-file-name plugin-name directory))
|
||||
(load-plugin
|
||||
(lambda ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(release-lock *plugin-table-lock*)
|
||||
(decline))
|
||||
(lambda ()
|
||||
;; load-config-file does not care about cwd(?)
|
||||
;; --> absolute file name needed
|
||||
(load-config-file full-plugin-name)
|
||||
;; plugin-structure to load must be named "plugin"
|
||||
(let ((plugin-structure (reify-structure 'plugin)))
|
||||
(format #t "cwd: ~s~%" (cwd))
|
||||
(load-structure plugin-structure)
|
||||
(table-set! *plugin-table* full-plugin-name
|
||||
(cons plugin-structure
|
||||
(file-last-mod full-plugin-name)))
|
||||
;; only now the lock may be released
|
||||
(release-lock *plugin-table-lock*)
|
||||
plugin-structure))))))
|
||||
|
||||
(obtain-lock *plugin-table-lock*)
|
||||
(let ((plugin (table-ref *plugin-table* plugin-name)))
|
||||
(let ((plugin (table-ref *plugin-table* full-plugin-name)))
|
||||
(if plugin
|
||||
(if (equal? (file-last-mod plugin-name)
|
||||
(if (equal? (file-last-mod full-plugin-name)
|
||||
(cdr plugin))
|
||||
(begin
|
||||
(release-lock *plugin-table-lock*)
|
||||
|
|
@ -263,8 +266,8 @@ You can try starting at the <A HREF=~a>beginning</a>."
|
|||
";k" (submatch (* digit)) ; Instance-ID
|
||||
";c" (+ digit) "-" (submatch (* digit)))) ; Continuation-ID
|
||||
|
||||
(define (make-resume-url full-path instance-id continuation-counter continuation-id)
|
||||
(string-append full-path
|
||||
(define (make-resume-url path-string instance-id continuation-counter continuation-id)
|
||||
(string-append path-string
|
||||
";k" (number->string (session-instance-id))
|
||||
";c" (number->string continuation-counter)
|
||||
"-" (number->string continuation-id)))
|
||||
|
|
|
|||
|
|
@ -134,7 +134,7 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
|
|||
simultaneous-requests)
|
||||
|
||||
(httpd (with-port port
|
||||
; (with-root-directory (absolute-file-name "./web-server/root")
|
||||
(with-root-directory (cwd)
|
||||
(with-simultaneous-requests simultaneous-requests
|
||||
(with-syslog? #t
|
||||
(with-logfile log-file-name
|
||||
|
|
@ -147,8 +147,9 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
|
|||
(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)))))))))
|
||||
(rooted-file-or-directory-handler htdocs-dir))))))))))
|
||||
))
|
||||
|
||||
;; EOF
|
||||
|
||||
;;; Local Variables:
|
||||
|
|
|
|||
|
|
@ -119,13 +119,14 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
|
|||
log-file-name)
|
||||
|
||||
(httpd (with-port port
|
||||
(with-root-directory (cwd)
|
||||
(with-syslog? #t
|
||||
(with-logfile log-file-name
|
||||
(with-request-handler
|
||||
(tilde-home-dir-handler "public_html"
|
||||
(alist-path-dispatcher
|
||||
(list (cons "cgi" (cgi-handler cgi-bin-dir)))
|
||||
(rooted-file-or-directory-handler htdocs-dir)))))))))
|
||||
(rooted-file-or-directory-handler htdocs-dir))))))))))
|
||||
))
|
||||
;; EOF
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue