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

Added svn:eol-line = native property to newly added files.

Browse Source 
svn: r7161
This commit is contained in:
Jens Axel Soegaard 2007-08-25 19:13:33 +00:00
parent 6d8b8a3390
commit 02dde4ec4b
7 changed files with 552 additions and 552 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
collects/help/launch.ss
View File

@ -1,36 +1,36 @@
;;; launch.ss ;;; launch.ss
; PURPOSE ; PURPOSE
; This file launches a web-server serving an online ; This file launches a web-server serving an online
; version of the HelpDesk pages. ; version of the HelpDesk pages.
; This is intended for testing the online version, ; This is intended for testing the online version,
; not as a way of deplying it. ; not as a way of deplying it.
; NOTES ; NOTES
; The web-server uses the port given by internal-port ; The web-server uses the port given by internal-port
; in "collects/help/private/internal-hp.ss". ; in "collects/help/private/internal-hp.ss".
; Change the parameter current-helpdesk-platform ; Change the parameter current-helpdesk-platform
; in "collects/help/servlets/private/platform.ss" ; in "collects/help/servlets/private/platform.ss"
; to 'external-browser when testing the online version. ; to 'external-browser when testing the online version.
; Startpage: ; Startpage:
; http://localhost:8000/servlets/home.ss ; http://localhost:8000/servlets/home.ss
; (where 8000 is the port given by internal-port) ; (where 8000 is the port given by internal-port)
(require (lib "web-server.ss" "web-server") (require (lib "web-server.ss" "web-server")
(lib "web-config-unit.ss" "web-server") (lib "web-config-unit.ss" "web-server")
"private/config.ss" "private/config.ss"
"private/internal-hp.ss") "private/internal-hp.ss")
; start the HelpDesk server, and store a shutdown ; start the HelpDesk server, and store a shutdown
(define shutdown (define shutdown
(serve/web-config@ config)) (serve/web-config@ config))
(display "Did you remember to change current-helpdesk-platform in platform.ss?\n\n") (display "Did you remember to change current-helpdesk-platform in platform.ss?\n\n")
(display (format "Start here: http://~a:~a/servlets/home.ss\n\n" (display (format "Start here: http://~a:~a/servlets/home.ss\n\n"
internal-host internal-port)) internal-host internal-port))
(display "Press enter to shutdown.\n") (display "Press enter to shutdown.\n")
(read-line) (read-line)
;(shutdown) ;(shutdown)

12
collects/help/servlets/private/helpdesk.css
View File

@ -1,6 +1,6 @@
.sansa { font-family: Arial, Helvetica, sans-serif; } .sansa { font-family: Arial, Helvetica, sans-serif; }
.sansa a:link { color: #3a652b; text-decoration: none; background-color: transparent; } .sansa a:link { color: #3a652b; text-decoration: none; background-color: transparent; }
.sansa a:visited { color: #3a652b; text-decoration: none; background-color: transparent; } .sansa a:visited { color: #3a652b; text-decoration: none; background-color: transparent; }
.sansa a:active { color: #3a652b; text-decoration: none; background-color: #97d881; } .sansa a:active { color: #3a652b; text-decoration: none; background-color: #97d881; }
.sansa a:hover { color: #3a652b; text-decoration: none; background-color: #97d881; } .sansa a:hover { color: #3a652b; text-decoration: none; background-color: #97d881; }
body { background-color: white; font-family: Arial, Helvetica, sans-serif; } body { background-color: white; font-family: Arial, Helvetica, sans-serif; }

372
collects/help/servlets/private/html.ss
View File

@ -1,187 +1,187 @@
(module html mzscheme (module html mzscheme
(provide (all-defined)) (provide (all-defined))
(require (lib "servlets/private/search-util.ss" "help") (require (lib "servlets/private/search-util.ss" "help")
(lib "servlet.ss" "web-server") (lib "servlet.ss" "web-server")
(lib "etc.ss") (lib "etc.ss")
(lib "kw.ss") (lib "kw.ss")
(lib "port.ss") (lib "port.ss")
"url.ss") "url.ss")
;;; ;;;
;;; STYLESHEET ;;; STYLESHEET
;;; ;;;
; css : -> string ; css : -> string
; fetch stylesheet from disk ; fetch stylesheet from disk
; (convenient during development) ; (convenient during development)
(define (css) (define (css)
(define (port->string port) (define (port->string port)
(let ([os (open-output-string)]) (let ([os (open-output-string)])
(copy-port port os) (copy-port port os)
(get-output-string os))) (get-output-string os)))
(call-with-input-file (call-with-input-file
(build-path (this-expression-source-directory) (build-path (this-expression-source-directory)
"helpdesk.css") "helpdesk.css")
port->string)) port->string))
;;; ;;;
;;; GENERATE XML FOR THE ENTIRE PAGE ;;; GENERATE XML FOR THE ENTIRE PAGE
;;; ;;;
; html-page : xexpr (list xml) (list xml) -> xexpr ; html-page : xexpr (list xml) (list xml) -> xexpr
(define/kw (html-page #:key title (top '()) (bodies '()) body) (define/kw (html-page #:key title (top '()) (bodies '()) body)
(let ([bodies (if body (append bodies (list body)) bodies)]) (let ([bodies (if body (append bodies (list body)) bodies)])
`(html `(html
(meta ((http-equiv "Content-Type") (content "text/html;charset=UTF-8"))) (meta ((http-equiv "Content-Type") (content "text/html;charset=UTF-8")))
(meta ((name "generator") (content "PLT Scheme"))) (meta ((name "generator") (content "PLT Scheme")))
; TODO: Ask Eli what exactly to put here in the online version ; TODO: Ask Eli what exactly to put here in the online version
;(script ((src "http://www.google-analytics.com/urchin.js") (type "text/javascript"))) ;(script ((src "http://www.google-analytics.com/urchin.js") (type "text/javascript")))
;(script ((type "text/javascript")) "_uacct=\"UA-808258-1\";_udn=\"plt-scheme.org\";urchinTracker();") ;(script ((type "text/javascript")) "_uacct=\"UA-808258-1\";_udn=\"plt-scheme.org\";urchinTracker();")
(head (title ,title) (head (title ,title)
(style ((type "text/css")) "\n" (style ((type "text/css")) "\n"
,(css)) ,(css))
; TODO: Check the icons work in online version ; TODO: Check the icons work in online version
(link ([rel "icon"] [href "/help/servlets/plticon.ico"] [type "image/ico"])) (link ([rel "icon"] [href "/help/servlets/plticon.ico"] [type "image/ico"]))
(link ([rel "shortcut icon"] [href "/help/servlets/plticon.ico"]))) (link ([rel "shortcut icon"] [href "/help/servlets/plticon.ico"])))
(body (body
,@top ,@top
,@bodies)))) ,@bodies))))
; html-select : string (list string) natural -> xexpr ; html-select : string (list string) natural -> xexpr
(define (html-select name descriptions selected-index) (define (html-select name descriptions selected-index)
`(select ((name ,name)) `(select ((name ,name))
,@(let loop ([i 0] [ds descriptions] [xexprs '()]) ,@(let loop ([i 0] [ds descriptions] [xexprs '()])
(cond (cond
[(null? ds) (reverse! xexprs)] [(null? ds) (reverse! xexprs)]
[(= i selected-index) (loop (+ i 1) (cdr ds) [(= i selected-index) (loop (+ i 1) (cdr ds)
(cons (car ds) (cons (car ds)
(cons `(option ((selected "selected"))) (cons `(option ((selected "selected")))
xexprs)))] xexprs)))]
[else (loop (+ i 1) (cdr ds) [else (loop (+ i 1) (cdr ds)
(cons (car ds) (cons (car ds)
(cons `(option) (cons `(option)
xexprs)))])))) xexprs)))]))))
;;; ;;;
;;; THE TOP SEARCH BAR ;;; THE TOP SEARCH BAR
;;; (online version online) ;;; (online version online)
; html-top : requrest -> (list xml) ; html-top : requrest -> (list xml)
(define (html-top request) (define (html-top request)
(let* ([bindings (request-bindings request)] (let* ([bindings (request-bindings request)]
[search-string (get-binding bindings 'search-string "")] [search-string (get-binding bindings 'search-string "")]
[search-type (get-binding bindings 'search-type search-type-default)] [search-type (get-binding bindings 'search-type search-type-default)]
[match-type (get-binding bindings 'match-type match-type-default)]) [match-type (get-binding bindings 'match-type match-type-default)])
`((div ((style "border: 1px solid black; padding: 3px; background-color: #74ca56; ")) `((div ((style "border: 1px solid black; padding: 3px; background-color: #74ca56; "))
(table ((width "98%")) (table ((width "98%"))
(tr (td ((align "right")) (tr (td ((align "right"))
(img ((class "image") (img ((class "image")
(src "http://www.plt-scheme.org/plt-green.jpg") (src "http://www.plt-scheme.org/plt-green.jpg")
(width "133") (height "128") (alt "[icon]")))) (width "133") (height "128") (alt "[icon]"))))
(td ((align "center")) (td ((align "center"))
(form ((method "GET") (action ,url-helpdesk-results)) (form ((method "GET") (action ,url-helpdesk-results))
(table (tr (td ((align "center") (class "sansa")) (table (tr (td ((align "center") (class "sansa"))
"Search the Help Desk for documentation on: " )) "Search the Help Desk for documentation on: " ))
(tr (td (input ((name "search-string") (type "text") (size "70") (tr (td (input ((name "search-string") (type "text") (size "70")
(value ,search-string)))) (value ,search-string))))
(td 'nbsp 'nbsp (button "Search"))) (td 'nbsp 'nbsp (button "Search")))
(tr (td ((align "center")) (tr (td ((align "center"))
,(html-select "search-type" ,(html-select "search-type"
search-type-descriptions search-type-descriptions
(search-type->index search-type)) (search-type->index search-type))
'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 'nbsp
,(html-select "match-type" ,(html-select "match-type"
match-type-descriptions match-type-descriptions
(match-type->index match-type))))))) (match-type->index match-type)))))))
(td 'nbsp) (td 'nbsp) (td 'nbsp) (td 'nbsp) (td 'nbsp) (td 'nbsp)
(td (table (tr (td ((align "center")) (td (table (tr (td ((align "center"))
(a ((href ,url-helpdesk-home) (class "sansa")) "HOME"))) (a ((href ,url-helpdesk-home) (class "sansa")) "HOME")))
(tr (td ((align "center")) (tr (td ((align "center"))
(a ((href ,url-helpdesk-manuals) (class "sansa")) "MANUALS"))))) (a ((href ,url-helpdesk-manuals) (class "sansa")) "MANUALS")))))
))) )))
(p " ")))) (p " "))))
;;; ;;;
;;; BINDINGS ;;; BINDINGS
;;; ;;;
(define (get-binding bindings name default-value) (define (get-binding bindings name default-value)
(if (exists-binding? name bindings) (if (exists-binding? name bindings)
(extract-binding/single name bindings) (extract-binding/single name bindings)
default-value)) default-value))
(define (delete-binding id bindings) (define (delete-binding id bindings)
(cond (cond
[(null? bindings) [(null? bindings)
'()] '()]
[(equal? (binding-id (car bindings)) id) [(equal? (binding-id (car bindings)) id)
(cdr bindings)] (cdr bindings)]
[else [else
(cons (car bindings) (cons (car bindings)
(delete-binding id (cdr bindings)))])) (delete-binding id (cdr bindings)))]))
(define (delete-bindings ids bindings) (define (delete-bindings ids bindings)
(cond [(null? ids) bindings] (cond [(null? ids) bindings]
[else (delete-bindings (cdr ids) [else (delete-bindings (cdr ids)
(delete-binding (car ids) (delete-binding (car ids)
bindings))])) bindings))]))
(define (display-binding binding) (define (display-binding binding)
; for debugging ; for debugging
(display "binding: ") (display "binding: ")
(display (binding-id binding)) (display (binding-id binding))
(display "=") (display "=")
(write (binding:form-value binding)) (write (binding:form-value binding))
(newline)) (newline))
;;; ;;;
;;; SEARCH DESCRIPTIONS AND SHORT NAMES ;;; SEARCH DESCRIPTIONS AND SHORT NAMES
;;; ;;;
(define (search-type-description i) (define (search-type-description i)
(cadr (list-ref search-types i))) (cadr (list-ref search-types i)))
(define (match-type-description i) (define (match-type-description i)
(cadr (list-ref match-types i))) (cadr (list-ref match-types i)))
(define reversed-search-types (define reversed-search-types
(map reverse search-types)) (map reverse search-types))
(define reversed-match-types (define reversed-match-types
(map reverse match-types)) (map reverse match-types))
(define (search-type-description->search-type desc) (define (search-type-description->search-type desc)
(cond [(assoc desc reversed-search-types) => cadr] (cond [(assoc desc reversed-search-types) => cadr]
[else search-type-default])) [else search-type-default]))
(define (match-type-description->match-type desc) (define (match-type-description->match-type desc)
(cond [(assoc desc reversed-match-types) => cadr] (cond [(assoc desc reversed-match-types) => cadr]
[else match-type-default])) [else match-type-default]))
(define search-type->index (define search-type->index
(let* ([types (map car search-types)] (let* ([types (map car search-types)]
[len (length types)]) [len (length types)])
(lambda (t) (lambda (t)
(cond (cond
[(member t types) [(member t types)
=> (lambda (tail) (- len (length tail)))] => (lambda (tail) (- len (length tail)))]
[else -1])))) [else -1]))))
(define match-type->index (define match-type->index
(let* ([types (map car match-types)] (let* ([types (map car match-types)]
[len (length types)]) [len (length types)])
(lambda (t) (lambda (t)
(cond (cond
[(member t types) [(member t types)
=> (lambda (tail) (- len (length tail)))] => (lambda (tail) (- len (length tail)))]
[else -1])))) [else -1]))))
(define search-type-descriptions (define search-type-descriptions
(map cadr search-types)) (map cadr search-types))
(define match-type-descriptions (define match-type-descriptions
(map cadr match-types)) (map cadr match-types))
) )

20
collects/help/servlets/private/platform.ss
View File

@ -1,11 +1,11 @@
(module platform mzscheme (module platform mzscheme
(provide current-helpdesk-platform) (provide current-helpdesk-platform)
; internal browser or external browser? ; internal browser or external browser?
; (used to produce simpler html for the internal browser) ; (used to produce simpler html for the internal browser)
(define current-helpdesk-platform (define current-helpdesk-platform
(make-parameter (make-parameter
'internal-browser-simple ; main page only 'internal-browser-simple ; main page only
; 'internal-browser ; menu + main page ; 'internal-browser ; menu + main page
; 'external-browser ; 'external-browser
))) )))

248
collects/help/servlets/private/split-screen.ss
View File

@ -1,125 +1,125 @@
(module split-screen mzscheme (module split-screen mzscheme
(require (lib "match.ss") (require (lib "match.ss")
(only (lib "misc.ss" "swindle") mappend) (only (lib "misc.ss" "swindle") mappend)
"html.ss" "html.ss"
"url.ss" "url.ss"
"platform.ss") "platform.ss")
; These items are common to all split screens ; These items are common to all split screens
(define left-header-items (define left-header-items
`((VERBATIM (big (big (big (b (a ((href ,url-helpdesk-home)) "PLT Scheme Help Desk")))))))) `((VERBATIM (big (big (big (b (a ((href ,url-helpdesk-home)) "PLT Scheme Help Desk"))))))))
(define left-footer-items (define left-footer-items
(case (current-helpdesk-platform) (case (current-helpdesk-platform)
[(internal-browser) [(internal-browser)
'(nbsp)] '(nbsp)]
[else [else
'(nbsp '(nbsp
(VERBATIM (small (small (a ((href "http://www.plt-scheme.org/map.html")) "Site Map")))) (VERBATIM (small (small (a ((href "http://www.plt-scheme.org/map.html")) "Site Map"))))
(VERBATIM (hr ((noshade "1") (size "2") (color "#3a652b")))) (VERBATIM (hr ((noshade "1") (size "2") (color "#3a652b"))))
(VERBATIM (nobr (VERBATIM (nobr
(small ((class "sansa")) (small ((class "sansa"))
(a ((href "http://www.plt-scheme.org/")) "PLT") (a ((href "http://www.plt-scheme.org/")) "PLT")
nbsp "|" nbsp nbsp "|" nbsp
(a ((href "http://www.plt-scheme.org/software/drscheme/")) "DrScheme") (a ((href "http://www.plt-scheme.org/software/drscheme/")) "DrScheme")
nbsp "|" nbsp nbsp "|" nbsp
(a ((href "http://www.teach-scheme.org/")) "TeachScheme!") (a ((href "http://www.teach-scheme.org/")) "TeachScheme!")
nbsp "|" nbsp nbsp "|" nbsp
(a ((href "http://www.htdp.org/")) "HtDP") nbsp (a ((href "http://www.htdp.org/")) "HtDP") nbsp
"|" nbsp "|" nbsp
(a ((href "http://planet.plt-scheme.org/")) "PLaneT") (a ((href "http://planet.plt-scheme.org/")) "PLaneT")
nbsp))) nbsp)))
; Google Search for PLT Documentation ; Google Search for PLT Documentation
#;(VERBATIM (div ((align "center")) #;(VERBATIM (div ((align "center"))
(div ((style "display: inline; margin: 0; white-space: nowrap;")) (div ((style "display: inline; margin: 0; white-space: nowrap;"))
; The Google "Search Documentation" field and button ; The Google "Search Documentation" field and button
(form ((id "searchbox_010927490648632664335:4yu6uuqr9ia") (form ((id "searchbox_010927490648632664335:4yu6uuqr9ia")
(action "http://www.plt-scheme.org/search/") (action "http://www.plt-scheme.org/search/")
(style "display: inline; margin: 0;")) (style "display: inline; margin: 0;"))
(input ((type "hidden") (name "cx") (value "010927490648632664335:4yu6uuqr9ia"))) (input ((type "hidden") (name "cx") (value "010927490648632664335:4yu6uuqr9ia")))
(input ((type "text") (name "q") (size "16") (style "font-size: 75%;"))) (input ((type "text") (name "q") (size "16") (style "font-size: 75%;")))
(input ((type "hidden") (name "hq") (value "more:plt"))) (input ((type "hidden") (name "hq") (value "more:plt")))
(input ((type "hidden") (name "cxq") (value "more:docs"))) (input ((type "hidden") (name "cxq") (value "more:docs")))
(input ((type "submit") (name "sa") (value "Search Documentation") (input ((type "submit") (name "sa") (value "Search Documentation")
(style "font-size: 75%;"))) (style "font-size: 75%;")))
(input ((type "hidden") (name "cof") (value "FORID:9"))))) (input ((type "hidden") (name "cof") (value "FORID:9")))))
nbsp)))])) nbsp)))]))
; the internal browser makes a "split" screen by having the left items at the top, ; the internal browser makes a "split" screen by having the left items at the top,
; and the right items at the bottom ; and the right items at the bottom
(define (make-split-page/internal-browser title top-items left-items right-header right-items) (define (make-split-page/internal-browser title top-items left-items right-header right-items)
(html-page (html-page
#:title title #:title title
#:body `(div ,(html-left-items (append #;left-header-items #:body `(div ,(html-left-items (append #;left-header-items
left-items left-footer-items)) left-items left-footer-items))
(hr) (hr)
,@(html-right-items right-items)))) ,@(html-right-items right-items))))
(define (make-simple-page/internal-browser title top-items left-items right-header right-items) (define (make-simple-page/internal-browser title top-items left-items right-header right-items)
(html-page (html-page
#:title title #:title title
#:body (if (equal? left-items "home") #:body (if (equal? left-items "home")
`(div ,(html-left-items right-items)) `(div ,(html-left-items right-items))
`(div ,@(html-right-items right-items))))) `(div ,@(html-right-items right-items)))))
; an external is capable of displaying a proper split screen ; an external is capable of displaying a proper split screen
(define (make-split-page title top-items left-items right-header right-items) (define (make-split-page title top-items left-items right-header right-items)
(html-page (html-page
#:title title #:title title
#:bodies `(,@top-items ,(make-split-screen left-items right-header right-items)))) #:bodies `(,@top-items ,(make-split-screen left-items right-header right-items))))
(define (make-split-screen left-items right-header right-items) (define (make-split-screen left-items right-header right-items)
`(table ((height "80%") (width "100%") (align "center") (border "0") (cellspacing "0") (cellpadding "30")) `(table ((height "80%") (width "100%") (align "center") (border "0") (cellspacing "0") (cellpadding "30"))
(tr ((valign "top")) (tr ((valign "top"))
(td ((height "80%") (width "50%") (align "center") (valign "top") (bgcolor "#74ca56")) (td ((height "80%") (width "50%") (align "center") (valign "top") (bgcolor "#74ca56"))
; LEFT TABLE ; LEFT TABLE
(table ((align "center") (class "sansa") (border "0") (cellpadding "0") (cellspacing "4")) (table ((align "center") (class "sansa") (border "0") (cellpadding "0") (cellspacing "4"))
#;(tr (td ((align "center")) #;(tr (td ((align "center"))
(img ((src "http://www.plt-scheme.org/plt-green.jpg") (img ((src "http://www.plt-scheme.org/plt-green.jpg")
(width "133") (height "128") (alt "[icon]"))))) (width "133") (height "128") (alt "[icon]")))))
,(html-left-items (append left-header-items left-items left-footer-items))) ,(html-left-items (append left-header-items left-items left-footer-items)))
(td ((height "100%") (width "50%") (align "left") (valign "top")) (td ((height "100%") (width "50%") (align "left") (valign "top"))
; RIGHT TABLE ; RIGHT TABLE
(table ((width "80%") (class "sansa") (align "center") (border "0") (table ((width "80%") (class "sansa") (align "center") (border "0")
(cellpadding "0") (cellspacing "0")) (cellpadding "0") (cellspacing "0"))
(tr (td (h1 ,right-header))) (tr (td (h1 ,right-header)))
;(tr (td (small (small nbsp)))) ;(tr (td (small (small nbsp))))
(tr (td (table ((border "0") (cellpadding "3") (cellspacing "0") (width "100%")) (tr (td (table ((border "0") (cellpadding "3") (cellspacing "0") (width "100%"))
,@(html-right-items right-items)))))))))) ,@(html-right-items right-items))))))))))
;;; ;;;
;;; ITEM FORMATTING ;;; ITEM FORMATTING
;;; (ad hoc markup inherited) ;;; (ad hoc markup inherited)
(define (html-left-items items) (define (html-left-items items)
`(tr (td (table ,@(mappend html-left-item items))))) `(tr (td (table ,@(mappend html-left-item items)))))
(define (html-left-item item) (define (html-left-item item)
(match item (match item
['UP (list '(font ((size "-2")) nbsp))] ['UP (list '(font ((size "-2")) nbsp))]
['-- (list '(tr ((height "4")) (td ((colspan "2")))))] ['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
[('VERBATIM sxml) (list `(tr (td ((align "center")) ,sxml)))] [('VERBATIM sxml) (list `(tr (td ((align "center")) ,sxml)))]
[(header) (list `(tr (td #;((colspan "2")) ,header)))] [(header) (list `(tr (td #;((colspan "2")) ,header)))]
[(header body ...) (list `(tr (td #;((colspan "2")) ,header)) [(header body ...) (list `(tr (td #;((colspan "2")) ,header))
`(tr (td ,@body)))] `(tr (td ,@body)))]
[other (list other)])) [other (list other)]))
(define (html-right-items items) (define (html-right-items items)
(mappend html-right-item items)) (mappend html-right-item items))
(define (html-right-item item) (define (html-right-item item)
(match item (match item
['-- (list '(tr ((height "4")) (td ((colspan "2")))))] ['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
[('VERBATIM item) item] [('VERBATIM item) item]
[(body ...) (list body)])) [(body ...) (list body)]))
(provide make-split-screen (provide make-split-screen
make-split-page make-split-page
make-split-page/internal-browser make-split-page/internal-browser
make-simple-page/internal-browser) make-simple-page/internal-browser)
) )

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

@ -1,68 +1,68 @@
(module url mzscheme (module url mzscheme
(require "../../private/internal-hp.ss") (require "../../private/internal-hp.ss")
(provide (all-defined)) (provide (all-defined))
(define url-helpdesk-root (define url-helpdesk-root
(string-append (string-append
"http://" internal-host ":" (number->string internal-port) "/servlets/")) "http://" internal-host ":" (number->string internal-port) "/servlets/"))
(define url-helpdesk-home (string-append url-helpdesk-root "home.ss")) (define url-helpdesk-home (string-append url-helpdesk-root "home.ss"))
(define url-helpdesk-results (string-append url-helpdesk-root "results.ss")) (define url-helpdesk-results (string-append url-helpdesk-root "results.ss"))
(define (url-home-subpage subpage-str) (define (url-home-subpage subpage-str)
(string-append url-helpdesk-home "?subpage=" subpage-str)) (string-append url-helpdesk-home "?subpage=" subpage-str))
(define (version-major) (define (version-major)
; TODO: Fix this ; TODO: Fix this
(cond [(regexp-match #px"^(\\d+).*$" (version)) (cond [(regexp-match #px"^(\\d+).*$" (version))
=> cadr] => cadr]
[else "352"])) [else "352"]))
(define (url-manual-on-doc-server manual) (define (url-manual-on-doc-server manual)
(string-append (string-append
"http://download.plt-scheme.org/doc/" "http://download.plt-scheme.org/doc/"
(version-major) "/html/" manual "/")) (version-major) "/html/" manual "/"))
(define (url-static doc manual path) (define (url-static doc manual path)
(string-append url-helpdesk-root "static.ss/" doc "/" manual "/" path)) (string-append url-helpdesk-root "static.ss/" doc "/" manual "/" path))
(define url-external-announcement-list-archive "http://list.cs.brown.edu/pipermail/plt-announce/") (define url-external-announcement-list-archive "http://list.cs.brown.edu/pipermail/plt-announce/")
(define url-external-discussion-list-archive "http://list.cs.brown.edu/pipermail/plt-scheme/") (define url-external-discussion-list-archive "http://list.cs.brown.edu/pipermail/plt-scheme/")
(define url-external-discussion-list-archive-old "http://www.cs.utah.edu/plt/mailarch/") (define url-external-discussion-list-archive-old "http://www.cs.utah.edu/plt/mailarch/")
(define url-external-mailing-list-subscription "http://www.plt-scheme.org/maillist/") (define url-external-mailing-list-subscription "http://www.plt-scheme.org/maillist/")
(define url-external-send-bug-report "http://bugs.plt-scheme.org/") (define url-external-send-bug-report "http://bugs.plt-scheme.org/")
(define url-external-tour-of-drscheme "http://www.plt-scheme.org/software/drscheme/tour/") (define url-external-tour-of-drscheme "http://www.plt-scheme.org/software/drscheme/tour/")
(define url-external-planet "http://planet.plt-scheme.org/") (define url-external-planet "http://planet.plt-scheme.org/")
(define url-helpdesk-acknowledge (url-home-subpage "acknowledge")) (define url-helpdesk-acknowledge (url-home-subpage "acknowledge"))
(define url-helpdesk-books (url-home-subpage "books")) (define url-helpdesk-books (url-home-subpage "books"))
(define url-helpdesk-documentation (url-home-subpage "documentation")) (define url-helpdesk-documentation (url-home-subpage "documentation"))
(define url-helpdesk-drscheme (url-home-subpage "drscheme")) (define url-helpdesk-drscheme (url-home-subpage "drscheme"))
(define url-helpdesk-drscheme-faq (url-static "doc1" "drscheme" "drscheme-Z-H-5.html#node_chap_5")) (define url-helpdesk-drscheme-faq (url-static "doc1" "drscheme" "drscheme-Z-H-5.html#node_chap_5"))
(define url-helpdesk-drscheme-manual (url-static "doc1" "drscheme" "index.htm")) (define url-helpdesk-drscheme-manual (url-static "doc1" "drscheme" "index.htm"))
(define url-helpdesk-faq (url-home-subpage "faq")) (define url-helpdesk-faq (url-home-subpage "faq"))
(define url-helpdesk-help (url-home-subpage "help")) (define url-helpdesk-help (url-home-subpage "help"))
(define url-helpdesk-interface-essentials (url-static "doc1" "drscheme" "drscheme-Z-H-2.html#node_chap_2")) (define url-helpdesk-interface-essentials (url-static "doc1" "drscheme" "drscheme-Z-H-2.html#node_chap_2"))
(define url-helpdesk-known-bugs (url-home-subpage "known-bugs")) (define url-helpdesk-known-bugs (url-home-subpage "known-bugs"))
(define url-helpdesk-languages (url-home-subpage "languages")) (define url-helpdesk-languages (url-home-subpage "languages"))
(define url-helpdesk-libraries (url-home-subpage "libraries")) (define url-helpdesk-libraries (url-home-subpage "libraries"))
(define url-helpdesk-license (url-home-subpage "license")) (define url-helpdesk-license (url-home-subpage "license"))
(define url-helpdesk-manuals (url-home-subpage "manuals")) (define url-helpdesk-manuals (url-home-subpage "manuals"))
(define url-helpdesk-mailing-lists (url-home-subpage "mailing-lists")) (define url-helpdesk-mailing-lists (url-home-subpage "mailing-lists"))
(define url-helpdesk-mzlib (url-static "doc1" "mzlib" "mzlib.html")) (define url-helpdesk-mzlib (url-static "doc1" "mzlib" "mzlib.html"))
(define url-helpdesk-patches (url-home-subpage "patches")) (define url-helpdesk-patches (url-home-subpage "patches"))
(define url-helpdesk-program-design (url-home-subpage "program-design")) (define url-helpdesk-program-design (url-home-subpage "program-design"))
(define url-helpdesk-release (url-home-subpage "release")) (define url-helpdesk-release (url-home-subpage "release"))
(define url-helpdesk-release-notes (url-home-subpage "release-notes")) (define url-helpdesk-release-notes (url-home-subpage "release-notes"))
(define url-helpdesk-search (url-home-subpage "search")) (define url-helpdesk-search (url-home-subpage "search"))
(define url-helpdesk-software (url-home-subpage "software")) (define url-helpdesk-software (url-home-subpage "software"))
(define url-helpdesk-teachpacks (url-home-subpage "teachpacks")) (define url-helpdesk-teachpacks (url-home-subpage "teachpacks"))
(define url-helpdesk-teachscheme (url-home-subpage "teachscheme")) (define url-helpdesk-teachscheme (url-home-subpage "teachscheme"))
(define url-helpdesk-teachpacks-for-htdp (url-static "doc1" "teachpack" "index.html#HtDP")) (define url-helpdesk-teachpacks-for-htdp (url-static "doc1" "teachpack" "index.html#HtDP"))
(define url-helpdesk-teachpacks-for-htdc (url-static "doc1" "teachpack-htdc" "index.html#HtDC")) (define url-helpdesk-teachpacks-for-htdc (url-static "doc1" "teachpack-htdc" "index.html#HtDC"))
(define url-helpdesk-teach-yourself (url-static "doc1" "t-y-scheme" "index.htm")) (define url-helpdesk-teach-yourself (url-static "doc1" "t-y-scheme" "index.htm"))
(define url-helpdesk-tour (url-home-subpage "tour")) (define url-helpdesk-tour (url-home-subpage "tour"))
(define url-helpdesk-why-drscheme (url-home-subpage "why-drscheme")) (define url-helpdesk-why-drscheme (url-home-subpage "why-drscheme"))
) )

246
collects/help/servlets/static.ss
View File

@ -1,124 +1,124 @@
; Serve static documentation. ; Serve static documentation.
; A search bar is added on top of the screen, when an external browser is used. ; A search bar is added on top of the screen, when an external browser is used.
; (which is why we don't let the web-server serve the documentation directly) ; (which is why we don't let the web-server serve the documentation directly)
(module static mzscheme (module static mzscheme
(require (lib "private/mime-types.ss" "web-server") (require (lib "private/mime-types.ss" "web-server")
(lib "servlet.ss" "web-server") (lib "servlet.ss" "web-server")
(lib "xml.ss" "xml") (lib "xml.ss" "xml")
(lib "match.ss") (lib "match.ss")
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "dirs.ss" "setup") (lib "dirs.ss" "setup")
(lib "port.ss") (lib "port.ss")
"../private/standard-urls.ss" "../private/standard-urls.ss"
"../private/docpos.ss" "../private/docpos.ss"
"private/platform.ss" "private/platform.ss"
"private/html.ss") "private/html.ss")
(provide interface-version timeout start) (provide interface-version timeout start)
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
;;; ;;;
;;; PORT UTILS ;;; PORT UTILS
;;; ;;;
(define (port->string port) (define (port->string port)
(let ([os (open-output-string)]) (let ([os (open-output-string)])
(copy-port port os) (copy-port port os)
(get-output-string os))) (get-output-string os)))
(define (file->string path) (define (file->string path)
(call-with-input-file path (call-with-input-file path
port->string)) port->string))
(define (port->bytes port) (define (port->bytes port)
(let ([ob (open-output-bytes)]) (let ([ob (open-output-bytes)])
(copy-port port ob) (copy-port port ob)
(get-output-bytes ob))) (get-output-bytes ob)))
(define (file->bytes path) (define (file->bytes path)
(call-with-input-file path (call-with-input-file path
port->bytes)) port->bytes))
;;; ;;;
;;; MIME ;;; MIME
;;; ;;;
; get-mime-type : path -> string ; get-mime-type : path -> string
(define get-mime-type (define get-mime-type
(;make-get-mime-type (;make-get-mime-type
make-path->mime-type make-path->mime-type
(build-path (find-collects-dir) (build-path (find-collects-dir)
"web-server" "default-web-root" "mime.types"))) "web-server" "default-web-root" "mime.types")))
(define (text-mime-type? file-path) (define (text-mime-type? file-path)
(regexp-match #rx"^text" (regexp-match #rx"^text"
(get-mime-type file-path))) (get-mime-type file-path)))
;;; ;;;
;;; URL ;;; URL
;;; ;;;
; file-parts->file : string (list string) -> string ; file-parts->file : string (list string) -> string
; (list "foo" "bar" "baz") => "foo/bar/baz" ; (list "foo" "bar" "baz") => "foo/bar/baz"
(define (file-parts->file manual fs) (define (file-parts->file manual fs)
(apply string-append (apply string-append
(let loop ([fs (cons manual fs)]) (let loop ([fs (cons manual fs)])
(cond (cond
[(null? fs) (list "")] [(null? fs) (list "")]
[(null? (cdr fs)) (list (car fs))] [(null? (cdr fs)) (list (car fs))]
[else (cons (string-append (car fs) "/") [else (cons (string-append (car fs) "/")
(loop (cdr fs)))])))) (loop (cdr fs)))]))))
;;; ;;;
;;; TITLES ;;; TITLES
;;; ;;;
(define (short->manual-title s) (define (short->manual-title s)
(match (assoc (string->path s) known-docs) (match (assoc (string->path s) known-docs)
[#f "Documentation"] [#f "Documentation"]
[(path . long) long])) [(path . long) long]))
(define (start request) (define (start request)
(with-errors-to-browser (with-errors-to-browser
send/finish send/finish
(lambda () (lambda ()
(let* ([bindings (request-bindings request)] (let* ([bindings (request-bindings request)]
[file (get-binding bindings 'file "no file")] [file (get-binding bindings 'file "no file")]
[host (get-binding bindings 'host "no host")] [host (get-binding bindings 'host "no host")]
[url (request-uri request)]) [url (request-uri request)])
(let-values (let-values
([(file-path host manual) ([(file-path host manual)
(match (map path/param-path (url-path url)) (match (map path/param-path (url-path url))
[("servlets" "static.ss" host manual . file-parts) [("servlets" "static.ss" host manual . file-parts)
(values (host+file->path host (file-parts->file manual file-parts)) (values (host+file->path host (file-parts->file manual file-parts))
host host
manual)])]) manual)])])
(cond (cond
[(not file-path) [(not file-path)
(list #"text/html" (list #"text/html"
"<html><head><title>Not found</title></head><body>File not found.</body></html>")] "<html><head><title>Not found</title></head><body>File not found.</body></html>")]
[(and (file-exists? file-path) [(and (file-exists? file-path)
(text-mime-type? file-path)) (text-mime-type? file-path))
(list (get-mime-type file-path) (list (get-mime-type file-path)
(string-append (xexpr->string (string-append (xexpr->string
(html-page (html-page
#:title (short->manual-title manual) #:title (short->manual-title manual)
#:top (case (current-helpdesk-platform) #:top (case (current-helpdesk-platform)
[(internal-browser) '()] [(internal-browser) '()]
[(internal-browser-simple) '()] [(internal-browser-simple) '()]
[else (html-top request)]) [else (html-top request)])
#:body " ")) #:body " "))
(file->string file-path)))] (file->string file-path)))]
[(file-exists? file-path) [(file-exists? file-path)
(list (get-mime-type file-path) (list (get-mime-type file-path)
(file->bytes file-path))] (file->bytes file-path))]
[else [else
(list #"text/html" (list #"text/html"
(format "<html><head><title>Not found</title></head><body>File not found: ~a</body></html>" (format "<html><head><title>Not found</title></head><body>File not found: ~a</body></html>"
file-path))])))))) file-path))]))))))
) )