suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make a launcher for standalone help-desk server, option for port number to listen on

Browse Source 
svn: r7174
This commit is contained in:
Eli Barzilay 2007-08-26 06:15:45 +00:00
parent 592be14b81
commit 897d92c3cf
10 changed files with 42 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/help/launch.ss → collects/help/help-desk-server.ss
View File

@ -1,4 +1,4 @@
;;; launch.ss
(module help-desk-server mzscheme
;; PURPOSE
;; This file launches a web-server serving an online
@ -8,23 +8,33 @@
;; NOTES
;; The web-server uses the port given by internal-port
;; in "collects/help/private/internal-hp.ss".
;; in "private/options.ss" by default.
;; Startpage:
;; http://localhost:8012/servlets/home.ss
;; (where 8012 is the port given by internal-port)
;; Startpage:
;; http://localhost:8000/servlets/home.ss
;; (where 8000 is the port given by internal-port)
(require (lib "web-server.ss" "web-server")
(lib "web-config-unit.ss" "web-server")
"private/config.ss"
(only "private/internal-hp.ss" internal-host)
"private/options.ss")
"private/internal-hp.ss"
"private/options.ss"
(lib "cmdline.ss"))
(helpdesk-platform 'external-browser)
(command-line
"help-desk-server"
(current-command-line-arguments)
(once-each
[("-p" "--port") port "port to run on"
(internal-port (string->number port))]))
(printf "launch>>>> ~s\n" (internal-port))
;; start the HelpDesk server, and store a shutdown
(define shutdown
(serve/web-config@ config))
(serve/web-config@ (make-config)))
(printf "\nStart here: http://~a:~a/servlets/home.ss\n\n"
internal-host (internal-port))
@ -32,3 +42,5 @@
(printf "Press enter to shutdown.\n")
(read-line)
;(shutdown)
)

8
collects/help/info.ss
View File

@ -2,7 +2,7 @@
(module info (lib "infotab.ss" "setup")
(define name "Help")
(define doc.txt "doc.txt")
(define compile-subcollections
(define compile-subcollections
'(("help" "private")
("help" "servlets")
("help" "servlets" "private")
@ -13,7 +13,9 @@
("help" "servlets" "scheme" "misc")))
(define help-desk-message
"Mr: (require (lib \"help-desk.ss\" \"help\"))")
(define mred-launcher-libraries (list "help.ss"))
(define mred-launcher-names (list "Help Desk"))
(define mred-launcher-libraries '("help.ss"))
(define mred-launcher-names '("Help Desk"))
(define mzscheme-launcher-libraries '("help-desk-server.ss"))
(define mzscheme-launcher-names '("Help Desk Server"))
(define install-collection "installer.ss")
(define compile-omit-files '("launch.ss")))

6
collects/help/private/config.ss
View File

@ -6,9 +6,9 @@
"internal-hp.ss"
(lib "namespace.ss" "web-server" "configuration"))
(provide config)
(provide make-config)
(define config
(define (make-config)
(let* ([build-normal-path
(lambda args
(normalize-path
@ -44,7 +44,7 @@
(mime-types "../../web-server/default-web-root/mime.types")
(password-authentication "passwords"))))])
(configuration-table-sexpr->web-config@
`((port ,internal-port)
`((port ,(internal-port))
(max-waiting 40)
(initial-connection-timeout 30)
(default-host-table

2
collects/help/private/get-help-url.ss
View File

@ -36,7 +36,7 @@
(λ (segments anchor)
(format "http://~a:~a/servlets/static.ss/~a~a~a"
internal-host
internal-port
(internal-port)
host
(apply string-append (map (λ (x) (format "/~a" (path->string x)))
segments))

6
collects/help/private/gui.ss
View File

@ -111,7 +111,7 @@
url]
;; one of the "collects" hosts:
[(and (equal? internal-port (url-port url))
[(and (equal? (internal-port) (url-port url))
(ormap (lambda (host)
(equal? host (url-host url)))
doc-hosts))
@ -160,7 +160,7 @@
url))]
;; one of the other internal hosts
[(and (equal? internal-port (url-port url))
[(and (equal? (internal-port) (url-port url))
(is-internal-host? (url-host url)))
url]
@ -194,7 +194,7 @@
(mixin (hyper-text<%> editor<%>) ()
(define/augment (url-allows-evaling? url)
(and (is-internal-host? (url-host url))
(equal? internal-port (url-port url))))
(equal? (internal-port) (url-port url))))
(define show-sk? #t)

7
collects/help/private/internal-hp.ss
View File

@ -2,7 +2,7 @@
(require (lib "dirs.ss" "setup")
(lib "config.ss" "planet")
"options.ss")
(provide (rename internal-port* internal-port)
(provide internal-port
is-internal-host? internal-host
collects-hosts collects-dirs
doc-hosts doc-dirs
@ -25,11 +25,6 @@
;; URLs.)
(define internal-host "localhost")
;; fake an internal-port binding (actually a parameter in options.ss)
(define-syntax internal-port*
(syntax-id-rules ()
[(x . xs) ((internal-port) . xs)]
[x (internal-port)]))
(define (is-internal-host? str)
(member str all-internal-hosts))

2
collects/help/private/link.ss
View File

@ -27,7 +27,7 @@
(define-unit-from-context inst@ setup:plt-installer^)
(define-unit-from-context real-tcp@ tcp^)
(define-unit-binding config@ config (import) (export web-config^))
(define-unit-binding config@ (make-config) (import) (export web-config^))
(define-compound-unit/infer help-desk@
(import)

10
collects/help/private/standard-urls.ss
View File

@ -27,21 +27,21 @@
(format "~a/html/~a/index.htm" (base-docs-url) manual-name))
(define (prefix-with-server suffix)
(format "http://~a:~a~a" internal-host internal-port suffix))
(format "http://~a:~a~a" internal-host (internal-port) suffix))
(define results-url-prefix (format "http://~a:~a/servlets/results.ss?" internal-host internal-port))
(define results-url-prefix (format "http://~a:~a/servlets/results.ss?" internal-host (internal-port)))
(define flush-manuals-path "/servlets/results.ss?flush=yes")
(define flush-manuals-url (format "http://~a:~a~a" internal-host internal-port flush-manuals-path))
(define flush-manuals-url (format "http://~a:~a~a" internal-host (internal-port) flush-manuals-path))
(define relative-results-url-prefix "/servlets/results.ss?")
(define home-page-url (format "http://~a:~a/servlets/home.ss" internal-host internal-port))
(define home-page-url (format "http://~a:~a/servlets/home.ss" internal-host (internal-port)))
(define (make-missing-manual-url coll name link)
(format "http://~a:~a/servlets/missing-manual.ss?manual=~a&name=~a&link=~a"
internal-host
internal-port
(internal-port)
coll
(uri-encode name)
(uri-encode link)))

2
collects/help/private/tcp-intercept.ss
View File

@ -96,7 +96,7 @@
(define (gen-tcp-connect raw)
(lambda (hostname-string port)
(if (and (is-internal-host? hostname-string)
(equal? internal-port port))
(equal? (internal-port) port))
(let-values ([(req-in req-out) (make-pipe)]
[(resp-in resp-out) (make-pipe)])
(parameterize ([current-custodian (make-custodian)])

5
collects/help/servlets/private/url.ss
View File

@ -4,8 +4,7 @@
(provide (all-defined))
(define url-helpdesk-root
(string-append
"http://" internal-host ":" (number->string internal-port) "/servlets/"))
(format "http://~a:~a/servlets/" internal-host (internal-port)))
(define url-helpdesk-home (string-append url-helpdesk-root "home.ss"))
(define url-helpdesk-results (string-append url-helpdesk-root "results.ss"))
@ -65,4 +64,4 @@
(define url-helpdesk-tour (url-home-subpage "tour"))
(define url-helpdesk-why-drscheme (url-home-subpage "why-drscheme"))
)
)