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