diff --git a/scheme/httpd/surflets/load-surflet-server.scm b/scheme/httpd/surflets/load-surflet-server.scm
index 5f44c6f..4756ec7 100644
--- a/scheme/httpd/surflets/load-surflet-server.scm
+++ b/scheme/httpd/surflets/load-surflet-server.scm
@@ -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)
\ No newline at end of file
+(batch 'off)
+(in 'scsh '(run (display "type (server) to start the server\n")))
+
diff --git a/scheme/httpd/surflets/start-surflet-server b/scheme/httpd/surflets/start-surflet-server
index f381a92..64dca51 100755
--- a/scheme/httpd/surflets/start-surflet-server
+++ b/scheme/httpd/surflets/start-surflet-server
@@ -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
diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm
index 38da3d9..8ce7582 100644
--- a/scheme/httpd/surflets/surflet-handler.scm
+++ b/scheme/httpd/surflets/surflet-handler.scm
@@ -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.
You can try starting at the beginning."
- (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 beginning."
(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 beginning."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 beginning."
";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)))
diff --git a/start-extended-web-server b/start-extended-web-server
index 0905a91..186fc74 100755
--- a/start-extended-web-server
+++ b/start-extended-web-server
@@ -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:
diff --git a/start-web-server b/start-web-server
index a95f8d2..41f40b9 100755
--- a/start-web-server
+++ b/start-web-server
@@ -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