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