scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Rename some procedure to get references clear and to remove a small bug

This commit is contained in:
interp 2002-11-03 18:00:12 +00:00
parent d026036bf3
commit 1374c4a8a6
1 changed files with 23 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
View File

@ -68,14 +68,14 @@
(define (unload-servlets outdated? servlet-names) (define (unload-servlets outdated? servlet-names)
(if-outdated outdated? (if-outdated outdated?
(show-outdated (make-callback servlets)) (show-outdated (make-callback show-servlets))
(for-each unload-servlet servlet-names))) (for-each unload-servlet servlet-names)))
(define (no-servlets) (define (no-servlets)
`(p "Currently, there are no servlets loaded " `(p "Currently, there are no servlets loaded "
(URL ,(make-callback servlets) "(reload)."))) (URL ,(make-callback show-servlets) "(reload).")))
(define (servlets req . maybe-update-text) (define (show-servlets req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
(loaded-servlets (sort-list! (get-loaded-servlets) string<?)) (loaded-servlets (sort-list! (get-loaded-servlets) string<?))
(outdated? (make-outdater)) (outdated? (make-outdater))
@ -103,21 +103,21 @@
`(p "Note that unloading the servlets does not imply " `(p "Note that unloading the servlets does not imply "
"the unloading of instances of this servlet." "the unloading of instances of this servlet."
"This can be done on the " "This can be done on the "
(URL ,(make-callback instances) (URL ,(make-callback show-instances)
"instances adminstration page.")) "instances adminstration page."))
footer)) footer))
(if (not action) (if (not action)
(servlets 'no-req "Choose an action.") (show-servlets 'no-req "Choose an action.")
(if (and (null? selected-servlets) (if (and (null? selected-servlets)
(not (string=? action "unload all"))) (not (string=? action "unload all")))
(servlets 'no-req "You must choose at least one element.") (show-servlets 'no-req "You must choose at least one element.")
(cond (cond
((string=? action "unload") ((string=? action "unload")
(unload-servlets outdated? selected-servlets) (unload-servlets outdated? selected-servlets)
(servlets 'no-req "Servlets unloaded.")) (show-servlets 'no-req "Servlets unloaded."))
((string=? action "unload all") ((string=? action "unload all")
(unload-servlets outdated? loaded-servlets) (unload-servlets outdated? loaded-servlets)
(servlets 'no-req "Servlets unloaded.")) (show-servlets 'no-req "Servlets unloaded."))
((string=? action "view instances") ((string=? action "view instances")
(format #t "~s~%" selected-servlets) (format #t "~s~%" selected-servlets)
(let* ((path-stripped-selected-servlets (let* ((path-stripped-selected-servlets
@ -157,7 +157,8 @@
;; Can't use callback here, as there are no valid instances left. ;; Can't use callback here, as there are no valid instances left.
(URL "admin.scm" "Go back to main page."))) (URL "admin.scm" "Go back to main page.")))
(define (instances req . maybe-update-text) (define (show-instances req . maybe-update-text)
(format #t "show-instances called with req ~s~%" req)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
(current-instances (sort-list! (get-instances) instance-servlet-name<?))) (current-instances (sort-list! (get-instances) instance-servlet-name<?)))
(real-instances current-instances update-text))) (real-instances current-instances update-text)))
@ -169,14 +170,14 @@
(h2 "Instances") (h2 "Instances")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (footer `((hr)
(URL ,(make-callback servlets) "Return to servlets menu.") (br) (URL ,(make-callback show-servlets) "Return to servlets menu.") (br)
(URL ,(make-callback return-to-main-page) "Return to administration menu.") (URL ,(make-callback return-to-main-page) "Return to administration menu.")
(br) (br)
(URL "/" "Return to main menu."))) (URL "/" "Return to main menu.")))
(actions '("kill" (actions '("kill"
"adjust timeout" "adjust timeout"
"view continuations")) "view continuations"))
(instances-callback (make-callback instances))) (instances-callback (make-callback show-instances)))
(if (null? current-instances) (if (null? current-instances)
(send-html `(html (title ,title) (send-html `(html (title ,title)
(body ,@header ,(no-current-instances) ,footer))) (body ,@header ,(no-current-instances) ,footer)))
@ -214,7 +215,7 @@
(if (zero? (length selected-instances)) (if (zero? (length selected-instances))
"You must choose at least one instance." "You must choose at least one instance."
;; this does not return ;; this does not return
(continuations selected-instances)))) (show-continuations selected-instances))))
(else (else
(error "unknown action" action))))) (error "unknown action" action)))))
(real-instances current-instances new-update-text))))))) (real-instances current-instances new-update-text)))))))
@ -224,10 +225,10 @@
(define (no-current-continuations instance) (define (no-current-continuations instance)
`((p "Currently, there are no continuations for this instance. ") `((p "Currently, there are no continuations for this instance. ")
(p "You may " (URL ,(make-callback (p "You may " (URL ,(make-callback
(lambda (req) (continuations (list instance)))) (lambda (req) (show-continuations (list instance))))
"reload") "reload")
" this page or go back to the " " this page or go back to the "
(URL ,(make-callback instances) "instance table overview.")))) (URL ,(make-callback show-instances) "instance table overview."))))
(define (no-more-than-one-instance title header1) (define (no-more-than-one-instance title header1)
(send-html (send-html
@ -237,14 +238,14 @@
"one instance at a time. This will be changed in " "one instance at a time. This will be changed in "
"future revisions. Sorry for any inconvenience.") "future revisions. Sorry for any inconvenience.")
(p "You may choose to go back to the " (p "You may choose to go back to the "
(URL ,(make-callback instances) (URL ,(make-callback show-instances)
"instances administration page") "instances administration page")
" where you can select one instance."))))) " where you can select one instance.")))))
(define (continuation-id<? entry1 entry2) (define (continuation-id<? entry1 entry2)
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
(define (continuations instances . maybe-update-text) (define (show-continuations instances . maybe-update-text)
(let ((title "Servlet Adminstration - Continuations") (let ((title "Servlet Adminstration - Continuations")
(header1 '(h1 "Servlet Administration"))) (header1 '(h1 "Servlet Administration")))
(if (not (= 1 (length instances))) (if (not (= 1 (length instances)))
@ -265,14 +266,14 @@
(p (font (@ (color "red")) ,update-text))))) (p (font (@ (color "red")) ,update-text)))))
(footer (footer
`((hr) `((hr)
(URL ,(make-callback servlets) "Return to servlets menu.") (br) (URL ,(make-callback show-servlets) "Return to servlets menu.") (br)
(URL ,(make-callback instances) "Return to instances menu.") (br) (URL ,(make-callback show-instances) "Return to instances menu.") (br)
(URL ,(make-callback return-to-main-page) "Return to administration menu.") (URL ,(make-callback return-to-main-page) "Return to administration menu.")
(br) (br)
(URL "/" "Return to main menu."))) (URL "/" "Return to main menu.")))
(actions '("delete" "delete all")) (actions '("delete" "delete all"))
(continuations-callback (make-callback (lambda (req) (continuations-callback (make-callback (lambda (req)
(continuations instances))))) (show-continuations instances)))))
(if (null? current-continuations) (if (null? current-continuations)
(send-html `(html (title ,title) (send-html `(html (title ,title)
(body ,header (body ,header
@ -289,7 +290,7 @@
actions actions
footer) footer)
(if (not action) (if (not action)
(continuations instances "Choose an action.") (show-continuations instances "Choose an action.")
(begin (begin
(cond (cond
((string=? action "delete") ((string=? action "delete")
@ -300,7 +301,7 @@
instance-id current-continuations)) instance-id current-continuations))
(else (else
(error "unknown action" action))) (error "unknown action" action)))
(continuations instances "Deleted.")))))))))) (show-continuations instances "Deleted."))))))))))
(define (delete-continuations outdated? continuations-callback (define (delete-continuations outdated? continuations-callback
instance-id continuations) instance-id continuations)
@ -318,6 +319,6 @@
"admin.scm" "admin.scm"))) "admin.scm" "admin.scm")))
(define (main req) (define (main req)
(servlets req)) (show-servlets req))
)) ))