rename PLUGIN --> SERVLET
This commit is contained in:
parent
349402b7cc
commit
85e75950a3
|
@ -32,7 +32,7 @@
|
|||
(body (cddr expr)))
|
||||
`(,%lambda ,(interface-value-names interface-name) ,@body))))
|
||||
|
||||
;(with-names-from-rt-structure plugin plugin-interface (main))
|
||||
;(with-names-from-rt-structure servlet servlet-interface (main))
|
||||
(define-syntax with-names-from-rt-structure
|
||||
(lambda (expr rename compare)
|
||||
(let ((%lambda (rename 'lambda))
|
||||
|
@ -68,15 +68,15 @@
|
|||
(define-interface servlet-handler-interface
|
||||
(export servlet-handler))
|
||||
|
||||
(define-interface servlet-handler/plugin-interface
|
||||
(define-interface servlet-handler/servlet-interface
|
||||
(export send/suspend ;send and suspend
|
||||
send/finish ;send and finish
|
||||
send ;just send (no finish, no suspend)
|
||||
))
|
||||
|
||||
(define-interface servlet-handler/admin-interface
|
||||
(export get-loaded-plugins
|
||||
unload-plugin
|
||||
(export get-loaded-servlets
|
||||
unload-servlet
|
||||
set-instance-lifetime!
|
||||
get-instance-lifetime
|
||||
get-instances
|
||||
|
@ -89,7 +89,7 @@
|
|||
|
||||
(define-structures
|
||||
((servlet-handler servlet-handler-interface)
|
||||
(servlet-handler/plugin servlet-handler/plugin-interface)
|
||||
(servlet-handler/servlet servlet-handler/servlet-interface)
|
||||
(servlet-handler/admin servlet-handler/admin-interface))
|
||||
(open httpd-responses
|
||||
httpd-request
|
||||
|
@ -152,7 +152,7 @@
|
|||
make-callback))
|
||||
|
||||
(define-structure servlets servlets-interface
|
||||
(open servlet-handler/plugin
|
||||
(open servlet-handler/servlet
|
||||
httpd-responses
|
||||
httpd-request ; HTTP-URL:SEARCH
|
||||
url ; REQUEST:URL
|
||||
|
@ -167,7 +167,7 @@
|
|||
scheme)
|
||||
(files servlets))
|
||||
|
||||
(define-interface plugin-interface
|
||||
(define-interface servlet-interface
|
||||
(export main)) ; MAIN gets one parameter, the REQUEST
|
||||
|
||||
(define-interface shift-reset-interface
|
||||
|
|
|
@ -5,14 +5,14 @@
|
|||
;;(load-config-file "test.scm") --> nothing
|
||||
;; load config file containing structure definition
|
||||
;;
|
||||
;; (reify-structure 'plugin) --> #{Rt-stucture plugin}
|
||||
;; (reify-structure 'servlet) --> #{Rt-stucture servlet}
|
||||
;; gets structure info about a structure
|
||||
;;
|
||||
;; (define plugin ##)
|
||||
;; (load-structure plugin)
|
||||
;; (define servlet ##)
|
||||
;; (load-structure servlet)
|
||||
;; loads rt-structure
|
||||
;;
|
||||
;; (rt-structure-binding plugin 'main) --> value
|
||||
;; (rt-structure-binding servlet 'main) --> value
|
||||
;; get a binding of a structure
|
||||
|
||||
|
||||
|
|
|
@ -34,7 +34,7 @@
|
|||
set-session-return-continuation!))
|
||||
|
||||
(define-record options
|
||||
(cache-plugins? #t)
|
||||
(cache-servlets? #t)
|
||||
(instance-lifetime 600)) ; in seconds
|
||||
|
||||
(define *options* (make-options))
|
||||
|
@ -65,12 +65,12 @@
|
|||
; (make-http-error-response http-status/accepted req "profiled"))
|
||||
; ((string=? path-string "reset") ; triggers cache clearing
|
||||
; (http-syslog (syslog-level debug)
|
||||
; "servlet-handler: clearing plugin cache")
|
||||
; (reset-plugin-cache!)
|
||||
; "servlet-handler: clearing servlet cache")
|
||||
; (reset-servlet-cache!)
|
||||
; (http-syslog (syslog-level debug)
|
||||
; "servlet-handler: clearing instance table")
|
||||
; (reset-instance-table!)
|
||||
; (make-http-error-response http-status/accepted req "plugin cache cleared"))
|
||||
; (make-http-error-response http-status/accepted req "servlet cache cleared"))
|
||||
((or (string=? request-method "GET")
|
||||
; (string=? request-method "POST")) ; do this at later time
|
||||
)
|
||||
|
@ -108,12 +108,12 @@
|
|||
(make-thread-safe-counter))) ; continuation counter
|
||||
(release-lock *instance-table-lock*)
|
||||
(register-session! instance-id 'no-return)
|
||||
(let ((plugin (with-fatal-error-handler*
|
||||
(let ((servlet (with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(instance-delete! instance-id)
|
||||
(decline))
|
||||
(lambda ()
|
||||
(get-plugin-rt-structure path-string servlet-path)))))
|
||||
(get-servlet-rt-structure path-string servlet-path)))))
|
||||
(fork-thread (instance-surveillance instance-id
|
||||
(+ (time)
|
||||
(options:instance-lifetime *options*))
|
||||
|
@ -123,7 +123,7 @@
|
|||
(with-cwd
|
||||
servlet-path
|
||||
(with-names-from-rt-structure
|
||||
plugin plugin-interface
|
||||
servlet servlet-interface
|
||||
(main req))))))))))
|
||||
|
||||
(define (instance-surveillance instance-id time-to-die memo)
|
||||
|
@ -307,77 +307,77 @@
|
|||
id)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; PLUGINs CACHE
|
||||
(define *plugin-table* (make-string-table)) ; path-string is index
|
||||
(define *plugin-table-lock* (make-lock))
|
||||
;; SERVLETs CACHE
|
||||
(define *servlet-table* (make-string-table)) ; path-string is index
|
||||
(define *servlet-table-lock* (make-lock))
|
||||
|
||||
;; PLUGIN-NAME is like "news-dir/latest-news.scm"
|
||||
(define (get-plugin-rt-structure plugin-name directory)
|
||||
(let* ((full-plugin-name (absolute-file-name plugin-name directory))
|
||||
(load-plugin
|
||||
;; SERVLET-NAME is like "news-dir/latest-news.scm"
|
||||
(define (get-servlet-rt-structure servlet-name directory)
|
||||
(let* ((full-servlet-name (absolute-file-name servlet-name directory))
|
||||
(load-servlet
|
||||
(lambda (cached?)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(if cached? (release-lock *plugin-table-lock*))
|
||||
(if cached? (release-lock *servlet-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)))
|
||||
(load-structure plugin-structure)
|
||||
(load-config-file full-servlet-name)
|
||||
;; servlet-structure to load must be named "servlet"
|
||||
(let ((plugin-structure (reify-structure 'servlet)))
|
||||
(load-structure servlet-structure)
|
||||
(if cached?
|
||||
(begin
|
||||
(table-set! *plugin-table* full-plugin-name
|
||||
(cons plugin-structure
|
||||
(file-last-mod full-plugin-name)))
|
||||
(table-set! *servlet-table* full-servlet-name
|
||||
(cons servlet-structure
|
||||
(file-last-mod full-servlet-name)))
|
||||
;; only now the lock may be released
|
||||
(release-lock *plugin-table-lock*)))
|
||||
plugin-structure))))))
|
||||
(if (options:cache-plugins? *options*)
|
||||
(release-lock *servlet-table-lock*)))
|
||||
servlet-structure))))))
|
||||
(if (options:cache-servlets? *options*)
|
||||
(begin
|
||||
;; The lock is only obtained and released, if plugins are
|
||||
;; cached. LOAD-PLUGIN gets the CACHED? parameter, so
|
||||
;; The lock is only obtained and released, if servlets are
|
||||
;; cached. LOAD-SERVLET gets the CACHED? parameter, so
|
||||
;; nothing may happen, if in the meanwhile caching is turned
|
||||
;; off.
|
||||
(obtain-lock *plugin-table-lock*)
|
||||
(let ((plugin (table-ref *plugin-table* full-plugin-name)))
|
||||
(if plugin
|
||||
(if (equal? (file-last-mod full-plugin-name)
|
||||
(cdr plugin))
|
||||
(obtain-lock *servlet-table-lock*)
|
||||
(let ((servlet (table-ref *servlet-table* full-servlet-name)))
|
||||
(if servlet
|
||||
(if (equal? (file-last-mod full-servlet-name)
|
||||
(cdr servlet))
|
||||
(begin
|
||||
(release-lock *plugin-table-lock*)
|
||||
(car plugin))
|
||||
(load-plugin #t))
|
||||
(load-plugin #t))))
|
||||
(load-plugin #f))))
|
||||
(release-lock *servlet-table-lock*)
|
||||
(car servlet))
|
||||
(load-servlet #t))
|
||||
(load-servlet #t))))
|
||||
(load-servlet #f))))
|
||||
|
||||
(define (get-loaded-plugins)
|
||||
(obtain-lock *plugin-table-lock*)
|
||||
(let ((loaded-plugins '()))
|
||||
(define (get-loaded-servlets)
|
||||
(obtain-lock *servlet-table-lock*)
|
||||
(let ((loaded-servlets '()))
|
||||
(table-walk
|
||||
(lambda (plugin-path rt-structure)
|
||||
(set! loaded-plugins (cons plugin-path loaded-plugins)))
|
||||
*plugin-table*)
|
||||
(release-lock *plugin-table-lock*)
|
||||
loaded-plugins))
|
||||
(lambda (servlet-path rt-structure)
|
||||
(set! loaded-servlets (cons servlet-path loaded-servlets)))
|
||||
*servlet-table*)
|
||||
(release-lock *servlet-table-lock*)
|
||||
loaded-servlets))
|
||||
|
||||
(define (unload-plugin plugin-name)
|
||||
(obtain-lock *plugin-table-lock*)
|
||||
(if (table-ref *plugin-table* plugin-name)
|
||||
(table-set! *plugin-table* plugin-name #f))
|
||||
(release-lock *plugin-table-lock*))
|
||||
(define (unload-servlet servlet-name)
|
||||
(obtain-lock *servlet-table-lock*)
|
||||
(if (table-ref *servlet-table* servlet-name)
|
||||
(table-set! *servlet-table* servlet-name #f))
|
||||
(release-lock *servlet-table-lock*))
|
||||
|
||||
(define (reset-plugin-cache!)
|
||||
(define (reset-servlet-cache!)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(release-lock *plugin-table-lock*)
|
||||
(release-lock *servlet-table-lock*)
|
||||
(decline))
|
||||
(lambda ()
|
||||
(obtain-lock *plugin-table-lock*)
|
||||
(set! *plugin-table* (make-string-table))
|
||||
(release-lock *plugin-table-lock*))))
|
||||
(obtain-lock *servlet-table-lock*)
|
||||
(set! *servlet-table* (make-string-table))
|
||||
(release-lock *servlet-table-lock*))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SESSION
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
;; utilities for plugin (servlets)
|
||||
;; utilities for servlet
|
||||
;; Copyright 2002, Andreas Bernauer
|
||||
|
||||
(define (send-html/suspend html-tree-maker)
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
(define-structure plugin plugin-interface
|
||||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
httpd-request
|
||||
url
|
||||
|
@ -14,7 +14,7 @@
|
|||
`(title ,title) '())
|
||||
(body
|
||||
,(if title `(h1 ,title) '())
|
||||
(p (a (@ href "reset") "click here to reset server's plugin cache"))
|
||||
(p (a (@ href "reset") "click here to reset server's servlet cache"))
|
||||
(p
|
||||
(form (@ (method "get")
|
||||
(action ,new-url))
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
(define-structure plugin plugin-interface
|
||||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
httpd-request
|
||||
url
|
||||
|
@ -18,7 +18,7 @@
|
|||
(body
|
||||
,(if title `(h1 ,title) '())
|
||||
(p (a (@ href "reset")
|
||||
"click here to reset server's plugin cache"))
|
||||
"click here to reset server's servlet cache"))
|
||||
(p
|
||||
(servlet-form ,new-url
|
||||
,input-text
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
(define-structure plugin plugin-interface
|
||||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
httpd-request
|
||||
handle-fatal-error
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
(define-structure plugin plugin-interface
|
||||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
httpd-request
|
||||
scsh
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
(define-structure plugin plugin-interface
|
||||
(define-structure servlet servlet-interface
|
||||
(open scsh
|
||||
scheme
|
||||
servlets
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
(define-structure plugin plugin-interface
|
||||
(define-structure servlet servlet-interface
|
||||
(open scsh
|
||||
scheme
|
||||
servlets
|
||||
|
|
Loading…
Reference in New Issue