Added svn:eol-line = native property to newly added files.
svn: r7161
This commit is contained in:
Jens Axel Soegaard
parent
6d8b8a3390
commit
02dde4ec4b
|
|
@ -1,36 +1,36 @@
|
|||
;;; launch.ss
|
||||
|
||||
; PURPOSE
|
||||
; This file launches a web-server serving an online
|
||||
; version of the HelpDesk pages.
|
||||
; This is intended for testing the online version,
|
||||
; not as a way of deplying it.
|
||||
|
||||
; NOTES
|
||||
; The web-server uses the port given by internal-port
|
||||
; in "collects/help/private/internal-hp.ss".
|
||||
|
||||
; Change the parameter current-helpdesk-platform
|
||||
; in "collects/help/servlets/private/platform.ss"
|
||||
; to 'external-browser when testing the online version.
|
||||
|
||||
; 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"
|
||||
"private/internal-hp.ss")
|
||||
|
||||
; start the HelpDesk server, and store a shutdown
|
||||
(define shutdown
|
||||
(serve/web-config@ config))
|
||||
|
||||
(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"
|
||||
internal-host internal-port))
|
||||
|
||||
(display "Press enter to shutdown.\n")
|
||||
(read-line)
|
||||
;(shutdown)
|
||||
;;; launch.ss
|
||||
|
||||
; PURPOSE
|
||||
; This file launches a web-server serving an online
|
||||
; version of the HelpDesk pages.
|
||||
; This is intended for testing the online version,
|
||||
; not as a way of deplying it.
|
||||
|
||||
; NOTES
|
||||
; The web-server uses the port given by internal-port
|
||||
; in "collects/help/private/internal-hp.ss".
|
||||
|
||||
; Change the parameter current-helpdesk-platform
|
||||
; in "collects/help/servlets/private/platform.ss"
|
||||
; to 'external-browser when testing the online version.
|
||||
|
||||
; 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"
|
||||
"private/internal-hp.ss")
|
||||
|
||||
; start the HelpDesk server, and store a shutdown
|
||||
(define shutdown
|
||||
(serve/web-config@ config))
|
||||
|
||||
(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"
|
||||
internal-host internal-port))
|
||||
|
||||
(display "Press enter to shutdown.\n")
|
||||
(read-line)
|
||||
;(shutdown)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
.sansa { font-family: Arial, Helvetica, sans-serif; }
|
||||
.sansa a:link { 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:hover { color: #3a652b; text-decoration: none; background-color: #97d881; }
|
||||
body { background-color: white; 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:visited { color: #3a652b; text-decoration: none; background-color: transparent; }
|
||||
.sansa a:active { 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; }
|
||||
|
|
|
|||
|
|
@ -1,187 +1,187 @@
|
|||
(module html mzscheme
|
||||
(provide (all-defined))
|
||||
|
||||
(require (lib "servlets/private/search-util.ss" "help")
|
||||
(lib "servlet.ss" "web-server")
|
||||
(lib "etc.ss")
|
||||
(lib "kw.ss")
|
||||
(lib "port.ss")
|
||||
"url.ss")
|
||||
|
||||
;;;
|
||||
;;; STYLESHEET
|
||||
;;;
|
||||
|
||||
; css : -> string
|
||||
; fetch stylesheet from disk
|
||||
; (convenient during development)
|
||||
(define (css)
|
||||
(define (port->string port)
|
||||
(let ([os (open-output-string)])
|
||||
(copy-port port os)
|
||||
(get-output-string os)))
|
||||
(call-with-input-file
|
||||
(build-path (this-expression-source-directory)
|
||||
"helpdesk.css")
|
||||
port->string))
|
||||
|
||||
;;;
|
||||
;;; GENERATE XML FOR THE ENTIRE PAGE
|
||||
;;;
|
||||
|
||||
; html-page : xexpr (list xml) (list xml) -> xexpr
|
||||
(define/kw (html-page #:key title (top '()) (bodies '()) body)
|
||||
(let ([bodies (if body (append bodies (list body)) bodies)])
|
||||
`(html
|
||||
(meta ((http-equiv "Content-Type") (content "text/html;charset=UTF-8")))
|
||||
(meta ((name "generator") (content "PLT Scheme")))
|
||||
; 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 ((type "text/javascript")) "_uacct=\"UA-808258-1\";_udn=\"plt-scheme.org\";urchinTracker();")
|
||||
(head (title ,title)
|
||||
(style ((type "text/css")) "\n"
|
||||
,(css))
|
||||
; TODO: Check the icons work in online version
|
||||
(link ([rel "icon"] [href "/help/servlets/plticon.ico"] [type "image/ico"]))
|
||||
(link ([rel "shortcut icon"] [href "/help/servlets/plticon.ico"])))
|
||||
(body
|
||||
,@top
|
||||
,@bodies))))
|
||||
|
||||
; html-select : string (list string) natural -> xexpr
|
||||
(define (html-select name descriptions selected-index)
|
||||
`(select ((name ,name))
|
||||
,@(let loop ([i 0] [ds descriptions] [xexprs '()])
|
||||
(cond
|
||||
[(null? ds) (reverse! xexprs)]
|
||||
[(= i selected-index) (loop (+ i 1) (cdr ds)
|
||||
(cons (car ds)
|
||||
(cons `(option ((selected "selected")))
|
||||
xexprs)))]
|
||||
[else (loop (+ i 1) (cdr ds)
|
||||
(cons (car ds)
|
||||
(cons `(option)
|
||||
xexprs)))]))))
|
||||
|
||||
;;;
|
||||
;;; THE TOP SEARCH BAR
|
||||
;;; (online version online)
|
||||
|
||||
; html-top : requrest -> (list xml)
|
||||
(define (html-top request)
|
||||
(let* ([bindings (request-bindings request)]
|
||||
[search-string (get-binding bindings 'search-string "")]
|
||||
[search-type (get-binding bindings 'search-type search-type-default)]
|
||||
[match-type (get-binding bindings 'match-type match-type-default)])
|
||||
`((div ((style "border: 1px solid black; padding: 3px; background-color: #74ca56; "))
|
||||
(table ((width "98%"))
|
||||
(tr (td ((align "right"))
|
||||
(img ((class "image")
|
||||
(src "http://www.plt-scheme.org/plt-green.jpg")
|
||||
(width "133") (height "128") (alt "[icon]"))))
|
||||
(td ((align "center"))
|
||||
(form ((method "GET") (action ,url-helpdesk-results))
|
||||
(table (tr (td ((align "center") (class "sansa"))
|
||||
"Search the Help Desk for documentation on: " ))
|
||||
(tr (td (input ((name "search-string") (type "text") (size "70")
|
||||
(value ,search-string))))
|
||||
(td 'nbsp 'nbsp (button "Search")))
|
||||
(tr (td ((align "center"))
|
||||
,(html-select "search-type"
|
||||
search-type-descriptions
|
||||
(search-type->index search-type))
|
||||
'nbsp 'nbsp 'nbsp 'nbsp
|
||||
,(html-select "match-type"
|
||||
match-type-descriptions
|
||||
(match-type->index match-type)))))))
|
||||
(td 'nbsp) (td 'nbsp) (td 'nbsp)
|
||||
(td (table (tr (td ((align "center"))
|
||||
(a ((href ,url-helpdesk-home) (class "sansa")) "HOME")))
|
||||
(tr (td ((align "center"))
|
||||
(a ((href ,url-helpdesk-manuals) (class "sansa")) "MANUALS")))))
|
||||
)))
|
||||
(p " "))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; BINDINGS
|
||||
;;;
|
||||
|
||||
(define (get-binding bindings name default-value)
|
||||
(if (exists-binding? name bindings)
|
||||
(extract-binding/single name bindings)
|
||||
default-value))
|
||||
|
||||
(define (delete-binding id bindings)
|
||||
(cond
|
||||
[(null? bindings)
|
||||
'()]
|
||||
[(equal? (binding-id (car bindings)) id)
|
||||
(cdr bindings)]
|
||||
[else
|
||||
(cons (car bindings)
|
||||
(delete-binding id (cdr bindings)))]))
|
||||
|
||||
(define (delete-bindings ids bindings)
|
||||
(cond [(null? ids) bindings]
|
||||
[else (delete-bindings (cdr ids)
|
||||
(delete-binding (car ids)
|
||||
bindings))]))
|
||||
|
||||
(define (display-binding binding)
|
||||
; for debugging
|
||||
(display "binding: ")
|
||||
(display (binding-id binding))
|
||||
(display "=")
|
||||
(write (binding:form-value binding))
|
||||
(newline))
|
||||
|
||||
;;;
|
||||
;;; SEARCH DESCRIPTIONS AND SHORT NAMES
|
||||
;;;
|
||||
|
||||
(define (search-type-description i)
|
||||
(cadr (list-ref search-types i)))
|
||||
|
||||
(define (match-type-description i)
|
||||
(cadr (list-ref match-types i)))
|
||||
|
||||
(define reversed-search-types
|
||||
(map reverse search-types))
|
||||
|
||||
(define reversed-match-types
|
||||
(map reverse match-types))
|
||||
|
||||
(define (search-type-description->search-type desc)
|
||||
(cond [(assoc desc reversed-search-types) => cadr]
|
||||
[else search-type-default]))
|
||||
|
||||
(define (match-type-description->match-type desc)
|
||||
(cond [(assoc desc reversed-match-types) => cadr]
|
||||
[else match-type-default]))
|
||||
|
||||
(define search-type->index
|
||||
(let* ([types (map car search-types)]
|
||||
[len (length types)])
|
||||
(lambda (t)
|
||||
(cond
|
||||
[(member t types)
|
||||
=> (lambda (tail) (- len (length tail)))]
|
||||
[else -1]))))
|
||||
|
||||
(define match-type->index
|
||||
(let* ([types (map car match-types)]
|
||||
[len (length types)])
|
||||
(lambda (t)
|
||||
(cond
|
||||
[(member t types)
|
||||
=> (lambda (tail) (- len (length tail)))]
|
||||
[else -1]))))
|
||||
|
||||
(define search-type-descriptions
|
||||
(map cadr search-types))
|
||||
|
||||
(define match-type-descriptions
|
||||
(map cadr match-types))
|
||||
|
||||
(module html mzscheme
|
||||
(provide (all-defined))
|
||||
|
||||
(require (lib "servlets/private/search-util.ss" "help")
|
||||
(lib "servlet.ss" "web-server")
|
||||
(lib "etc.ss")
|
||||
(lib "kw.ss")
|
||||
(lib "port.ss")
|
||||
"url.ss")
|
||||
|
||||
;;;
|
||||
;;; STYLESHEET
|
||||
;;;
|
||||
|
||||
; css : -> string
|
||||
; fetch stylesheet from disk
|
||||
; (convenient during development)
|
||||
(define (css)
|
||||
(define (port->string port)
|
||||
(let ([os (open-output-string)])
|
||||
(copy-port port os)
|
||||
(get-output-string os)))
|
||||
(call-with-input-file
|
||||
(build-path (this-expression-source-directory)
|
||||
"helpdesk.css")
|
||||
port->string))
|
||||
|
||||
;;;
|
||||
;;; GENERATE XML FOR THE ENTIRE PAGE
|
||||
;;;
|
||||
|
||||
; html-page : xexpr (list xml) (list xml) -> xexpr
|
||||
(define/kw (html-page #:key title (top '()) (bodies '()) body)
|
||||
(let ([bodies (if body (append bodies (list body)) bodies)])
|
||||
`(html
|
||||
(meta ((http-equiv "Content-Type") (content "text/html;charset=UTF-8")))
|
||||
(meta ((name "generator") (content "PLT Scheme")))
|
||||
; 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 ((type "text/javascript")) "_uacct=\"UA-808258-1\";_udn=\"plt-scheme.org\";urchinTracker();")
|
||||
(head (title ,title)
|
||||
(style ((type "text/css")) "\n"
|
||||
,(css))
|
||||
; TODO: Check the icons work in online version
|
||||
(link ([rel "icon"] [href "/help/servlets/plticon.ico"] [type "image/ico"]))
|
||||
(link ([rel "shortcut icon"] [href "/help/servlets/plticon.ico"])))
|
||||
(body
|
||||
,@top
|
||||
,@bodies))))
|
||||
|
||||
; html-select : string (list string) natural -> xexpr
|
||||
(define (html-select name descriptions selected-index)
|
||||
`(select ((name ,name))
|
||||
,@(let loop ([i 0] [ds descriptions] [xexprs '()])
|
||||
(cond
|
||||
[(null? ds) (reverse! xexprs)]
|
||||
[(= i selected-index) (loop (+ i 1) (cdr ds)
|
||||
(cons (car ds)
|
||||
(cons `(option ((selected "selected")))
|
||||
xexprs)))]
|
||||
[else (loop (+ i 1) (cdr ds)
|
||||
(cons (car ds)
|
||||
(cons `(option)
|
||||
xexprs)))]))))
|
||||
|
||||
;;;
|
||||
;;; THE TOP SEARCH BAR
|
||||
;;; (online version online)
|
||||
|
||||
; html-top : requrest -> (list xml)
|
||||
(define (html-top request)
|
||||
(let* ([bindings (request-bindings request)]
|
||||
[search-string (get-binding bindings 'search-string "")]
|
||||
[search-type (get-binding bindings 'search-type search-type-default)]
|
||||
[match-type (get-binding bindings 'match-type match-type-default)])
|
||||
`((div ((style "border: 1px solid black; padding: 3px; background-color: #74ca56; "))
|
||||
(table ((width "98%"))
|
||||
(tr (td ((align "right"))
|
||||
(img ((class "image")
|
||||
(src "http://www.plt-scheme.org/plt-green.jpg")
|
||||
(width "133") (height "128") (alt "[icon]"))))
|
||||
(td ((align "center"))
|
||||
(form ((method "GET") (action ,url-helpdesk-results))
|
||||
(table (tr (td ((align "center") (class "sansa"))
|
||||
"Search the Help Desk for documentation on: " ))
|
||||
(tr (td (input ((name "search-string") (type "text") (size "70")
|
||||
(value ,search-string))))
|
||||
(td 'nbsp 'nbsp (button "Search")))
|
||||
(tr (td ((align "center"))
|
||||
,(html-select "search-type"
|
||||
search-type-descriptions
|
||||
(search-type->index search-type))
|
||||
'nbsp 'nbsp 'nbsp 'nbsp
|
||||
,(html-select "match-type"
|
||||
match-type-descriptions
|
||||
(match-type->index match-type)))))))
|
||||
(td 'nbsp) (td 'nbsp) (td 'nbsp)
|
||||
(td (table (tr (td ((align "center"))
|
||||
(a ((href ,url-helpdesk-home) (class "sansa")) "HOME")))
|
||||
(tr (td ((align "center"))
|
||||
(a ((href ,url-helpdesk-manuals) (class "sansa")) "MANUALS")))))
|
||||
)))
|
||||
(p " "))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; BINDINGS
|
||||
;;;
|
||||
|
||||
(define (get-binding bindings name default-value)
|
||||
(if (exists-binding? name bindings)
|
||||
(extract-binding/single name bindings)
|
||||
default-value))
|
||||
|
||||
(define (delete-binding id bindings)
|
||||
(cond
|
||||
[(null? bindings)
|
||||
'()]
|
||||
[(equal? (binding-id (car bindings)) id)
|
||||
(cdr bindings)]
|
||||
[else
|
||||
(cons (car bindings)
|
||||
(delete-binding id (cdr bindings)))]))
|
||||
|
||||
(define (delete-bindings ids bindings)
|
||||
(cond [(null? ids) bindings]
|
||||
[else (delete-bindings (cdr ids)
|
||||
(delete-binding (car ids)
|
||||
bindings))]))
|
||||
|
||||
(define (display-binding binding)
|
||||
; for debugging
|
||||
(display "binding: ")
|
||||
(display (binding-id binding))
|
||||
(display "=")
|
||||
(write (binding:form-value binding))
|
||||
(newline))
|
||||
|
||||
;;;
|
||||
;;; SEARCH DESCRIPTIONS AND SHORT NAMES
|
||||
;;;
|
||||
|
||||
(define (search-type-description i)
|
||||
(cadr (list-ref search-types i)))
|
||||
|
||||
(define (match-type-description i)
|
||||
(cadr (list-ref match-types i)))
|
||||
|
||||
(define reversed-search-types
|
||||
(map reverse search-types))
|
||||
|
||||
(define reversed-match-types
|
||||
(map reverse match-types))
|
||||
|
||||
(define (search-type-description->search-type desc)
|
||||
(cond [(assoc desc reversed-search-types) => cadr]
|
||||
[else search-type-default]))
|
||||
|
||||
(define (match-type-description->match-type desc)
|
||||
(cond [(assoc desc reversed-match-types) => cadr]
|
||||
[else match-type-default]))
|
||||
|
||||
(define search-type->index
|
||||
(let* ([types (map car search-types)]
|
||||
[len (length types)])
|
||||
(lambda (t)
|
||||
(cond
|
||||
[(member t types)
|
||||
=> (lambda (tail) (- len (length tail)))]
|
||||
[else -1]))))
|
||||
|
||||
(define match-type->index
|
||||
(let* ([types (map car match-types)]
|
||||
[len (length types)])
|
||||
(lambda (t)
|
||||
(cond
|
||||
[(member t types)
|
||||
=> (lambda (tail) (- len (length tail)))]
|
||||
[else -1]))))
|
||||
|
||||
(define search-type-descriptions
|
||||
(map cadr search-types))
|
||||
|
||||
(define match-type-descriptions
|
||||
(map cadr match-types))
|
||||
|
||||
)
|
||||
|
|
@ -1,11 +1,11 @@
|
|||
(module platform mzscheme
|
||||
(provide current-helpdesk-platform)
|
||||
|
||||
; internal browser or external browser?
|
||||
; (used to produce simpler html for the internal browser)
|
||||
(define current-helpdesk-platform
|
||||
(make-parameter
|
||||
'internal-browser-simple ; main page only
|
||||
; 'internal-browser ; menu + main page
|
||||
; 'external-browser
|
||||
(module platform mzscheme
|
||||
(provide current-helpdesk-platform)
|
||||
|
||||
; internal browser or external browser?
|
||||
; (used to produce simpler html for the internal browser)
|
||||
(define current-helpdesk-platform
|
||||
(make-parameter
|
||||
'internal-browser-simple ; main page only
|
||||
; 'internal-browser ; menu + main page
|
||||
; 'external-browser
|
||||
)))
|
||||
|
|
@ -1,125 +1,125 @@
|
|||
(module split-screen mzscheme
|
||||
(require (lib "match.ss")
|
||||
(only (lib "misc.ss" "swindle") mappend)
|
||||
"html.ss"
|
||||
"url.ss"
|
||||
"platform.ss")
|
||||
|
||||
; These items are common to all split screens
|
||||
|
||||
(define left-header-items
|
||||
`((VERBATIM (big (big (big (b (a ((href ,url-helpdesk-home)) "PLT Scheme Help Desk"))))))))
|
||||
|
||||
(define left-footer-items
|
||||
(case (current-helpdesk-platform)
|
||||
[(internal-browser)
|
||||
'(nbsp)]
|
||||
[else
|
||||
'(nbsp
|
||||
(VERBATIM (small (small (a ((href "http://www.plt-scheme.org/map.html")) "Site Map"))))
|
||||
(VERBATIM (hr ((noshade "1") (size "2") (color "#3a652b"))))
|
||||
(VERBATIM (nobr
|
||||
(small ((class "sansa"))
|
||||
(a ((href "http://www.plt-scheme.org/")) "PLT")
|
||||
nbsp "|" nbsp
|
||||
(a ((href "http://www.plt-scheme.org/software/drscheme/")) "DrScheme")
|
||||
nbsp "|" nbsp
|
||||
(a ((href "http://www.teach-scheme.org/")) "TeachScheme!")
|
||||
nbsp "|" nbsp
|
||||
(a ((href "http://www.htdp.org/")) "HtDP") nbsp
|
||||
"|" nbsp
|
||||
(a ((href "http://planet.plt-scheme.org/")) "PLaneT")
|
||||
nbsp)))
|
||||
; Google Search for PLT Documentation
|
||||
#;(VERBATIM (div ((align "center"))
|
||||
(div ((style "display: inline; margin: 0; white-space: nowrap;"))
|
||||
; The Google "Search Documentation" field and button
|
||||
(form ((id "searchbox_010927490648632664335:4yu6uuqr9ia")
|
||||
(action "http://www.plt-scheme.org/search/")
|
||||
(style "display: inline; margin: 0;"))
|
||||
(input ((type "hidden") (name "cx") (value "010927490648632664335:4yu6uuqr9ia")))
|
||||
(input ((type "text") (name "q") (size "16") (style "font-size: 75%;")))
|
||||
(input ((type "hidden") (name "hq") (value "more:plt")))
|
||||
(input ((type "hidden") (name "cxq") (value "more:docs")))
|
||||
(input ((type "submit") (name "sa") (value "Search Documentation")
|
||||
(style "font-size: 75%;")))
|
||||
(input ((type "hidden") (name "cof") (value "FORID:9")))))
|
||||
nbsp)))]))
|
||||
|
||||
|
||||
; the internal browser makes a "split" screen by having the left items at the top,
|
||||
; and the right items at the bottom
|
||||
(define (make-split-page/internal-browser title top-items left-items right-header right-items)
|
||||
(html-page
|
||||
#:title title
|
||||
#:body `(div ,(html-left-items (append #;left-header-items
|
||||
left-items left-footer-items))
|
||||
(hr)
|
||||
,@(html-right-items right-items))))
|
||||
|
||||
(define (make-simple-page/internal-browser title top-items left-items right-header right-items)
|
||||
(html-page
|
||||
#:title title
|
||||
#:body (if (equal? left-items "home")
|
||||
`(div ,(html-left-items right-items))
|
||||
`(div ,@(html-right-items right-items)))))
|
||||
|
||||
; an external is capable of displaying a proper split screen
|
||||
(define (make-split-page title top-items left-items right-header right-items)
|
||||
(html-page
|
||||
#:title title
|
||||
#:bodies `(,@top-items ,(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"))
|
||||
(tr ((valign "top"))
|
||||
(td ((height "80%") (width "50%") (align "center") (valign "top") (bgcolor "#74ca56"))
|
||||
; LEFT TABLE
|
||||
(table ((align "center") (class "sansa") (border "0") (cellpadding "0") (cellspacing "4"))
|
||||
#;(tr (td ((align "center"))
|
||||
(img ((src "http://www.plt-scheme.org/plt-green.jpg")
|
||||
(width "133") (height "128") (alt "[icon]")))))
|
||||
,(html-left-items (append left-header-items left-items left-footer-items)))
|
||||
(td ((height "100%") (width "50%") (align "left") (valign "top"))
|
||||
; RIGHT TABLE
|
||||
(table ((width "80%") (class "sansa") (align "center") (border "0")
|
||||
(cellpadding "0") (cellspacing "0"))
|
||||
(tr (td (h1 ,right-header)))
|
||||
;(tr (td (small (small nbsp))))
|
||||
(tr (td (table ((border "0") (cellpadding "3") (cellspacing "0") (width "100%"))
|
||||
,@(html-right-items right-items))))))))))
|
||||
|
||||
;;;
|
||||
;;; ITEM FORMATTING
|
||||
;;; (ad hoc markup inherited)
|
||||
|
||||
(define (html-left-items items)
|
||||
`(tr (td (table ,@(mappend html-left-item items)))))
|
||||
|
||||
(define (html-left-item item)
|
||||
(match item
|
||||
['UP (list '(font ((size "-2")) nbsp))]
|
||||
['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
|
||||
[('VERBATIM sxml) (list `(tr (td ((align "center")) ,sxml)))]
|
||||
[(header) (list `(tr (td #;((colspan "2")) ,header)))]
|
||||
[(header body ...) (list `(tr (td #;((colspan "2")) ,header))
|
||||
`(tr (td ,@body)))]
|
||||
[other (list other)]))
|
||||
|
||||
(define (html-right-items items)
|
||||
(mappend html-right-item items))
|
||||
|
||||
(define (html-right-item item)
|
||||
(match item
|
||||
['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
|
||||
[('VERBATIM item) item]
|
||||
[(body ...) (list body)]))
|
||||
|
||||
|
||||
(provide make-split-screen
|
||||
make-split-page
|
||||
make-split-page/internal-browser
|
||||
make-simple-page/internal-browser)
|
||||
|
||||
(module split-screen mzscheme
|
||||
(require (lib "match.ss")
|
||||
(only (lib "misc.ss" "swindle") mappend)
|
||||
"html.ss"
|
||||
"url.ss"
|
||||
"platform.ss")
|
||||
|
||||
; These items are common to all split screens
|
||||
|
||||
(define left-header-items
|
||||
`((VERBATIM (big (big (big (b (a ((href ,url-helpdesk-home)) "PLT Scheme Help Desk"))))))))
|
||||
|
||||
(define left-footer-items
|
||||
(case (current-helpdesk-platform)
|
||||
[(internal-browser)
|
||||
'(nbsp)]
|
||||
[else
|
||||
'(nbsp
|
||||
(VERBATIM (small (small (a ((href "http://www.plt-scheme.org/map.html")) "Site Map"))))
|
||||
(VERBATIM (hr ((noshade "1") (size "2") (color "#3a652b"))))
|
||||
(VERBATIM (nobr
|
||||
(small ((class "sansa"))
|
||||
(a ((href "http://www.plt-scheme.org/")) "PLT")
|
||||
nbsp "|" nbsp
|
||||
(a ((href "http://www.plt-scheme.org/software/drscheme/")) "DrScheme")
|
||||
nbsp "|" nbsp
|
||||
(a ((href "http://www.teach-scheme.org/")) "TeachScheme!")
|
||||
nbsp "|" nbsp
|
||||
(a ((href "http://www.htdp.org/")) "HtDP") nbsp
|
||||
"|" nbsp
|
||||
(a ((href "http://planet.plt-scheme.org/")) "PLaneT")
|
||||
nbsp)))
|
||||
; Google Search for PLT Documentation
|
||||
#;(VERBATIM (div ((align "center"))
|
||||
(div ((style "display: inline; margin: 0; white-space: nowrap;"))
|
||||
; The Google "Search Documentation" field and button
|
||||
(form ((id "searchbox_010927490648632664335:4yu6uuqr9ia")
|
||||
(action "http://www.plt-scheme.org/search/")
|
||||
(style "display: inline; margin: 0;"))
|
||||
(input ((type "hidden") (name "cx") (value "010927490648632664335:4yu6uuqr9ia")))
|
||||
(input ((type "text") (name "q") (size "16") (style "font-size: 75%;")))
|
||||
(input ((type "hidden") (name "hq") (value "more:plt")))
|
||||
(input ((type "hidden") (name "cxq") (value "more:docs")))
|
||||
(input ((type "submit") (name "sa") (value "Search Documentation")
|
||||
(style "font-size: 75%;")))
|
||||
(input ((type "hidden") (name "cof") (value "FORID:9")))))
|
||||
nbsp)))]))
|
||||
|
||||
|
||||
; the internal browser makes a "split" screen by having the left items at the top,
|
||||
; and the right items at the bottom
|
||||
(define (make-split-page/internal-browser title top-items left-items right-header right-items)
|
||||
(html-page
|
||||
#:title title
|
||||
#:body `(div ,(html-left-items (append #;left-header-items
|
||||
left-items left-footer-items))
|
||||
(hr)
|
||||
,@(html-right-items right-items))))
|
||||
|
||||
(define (make-simple-page/internal-browser title top-items left-items right-header right-items)
|
||||
(html-page
|
||||
#:title title
|
||||
#:body (if (equal? left-items "home")
|
||||
`(div ,(html-left-items right-items))
|
||||
`(div ,@(html-right-items right-items)))))
|
||||
|
||||
; an external is capable of displaying a proper split screen
|
||||
(define (make-split-page title top-items left-items right-header right-items)
|
||||
(html-page
|
||||
#:title title
|
||||
#:bodies `(,@top-items ,(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"))
|
||||
(tr ((valign "top"))
|
||||
(td ((height "80%") (width "50%") (align "center") (valign "top") (bgcolor "#74ca56"))
|
||||
; LEFT TABLE
|
||||
(table ((align "center") (class "sansa") (border "0") (cellpadding "0") (cellspacing "4"))
|
||||
#;(tr (td ((align "center"))
|
||||
(img ((src "http://www.plt-scheme.org/plt-green.jpg")
|
||||
(width "133") (height "128") (alt "[icon]")))))
|
||||
,(html-left-items (append left-header-items left-items left-footer-items)))
|
||||
(td ((height "100%") (width "50%") (align "left") (valign "top"))
|
||||
; RIGHT TABLE
|
||||
(table ((width "80%") (class "sansa") (align "center") (border "0")
|
||||
(cellpadding "0") (cellspacing "0"))
|
||||
(tr (td (h1 ,right-header)))
|
||||
;(tr (td (small (small nbsp))))
|
||||
(tr (td (table ((border "0") (cellpadding "3") (cellspacing "0") (width "100%"))
|
||||
,@(html-right-items right-items))))))))))
|
||||
|
||||
;;;
|
||||
;;; ITEM FORMATTING
|
||||
;;; (ad hoc markup inherited)
|
||||
|
||||
(define (html-left-items items)
|
||||
`(tr (td (table ,@(mappend html-left-item items)))))
|
||||
|
||||
(define (html-left-item item)
|
||||
(match item
|
||||
['UP (list '(font ((size "-2")) nbsp))]
|
||||
['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
|
||||
[('VERBATIM sxml) (list `(tr (td ((align "center")) ,sxml)))]
|
||||
[(header) (list `(tr (td #;((colspan "2")) ,header)))]
|
||||
[(header body ...) (list `(tr (td #;((colspan "2")) ,header))
|
||||
`(tr (td ,@body)))]
|
||||
[other (list other)]))
|
||||
|
||||
(define (html-right-items items)
|
||||
(mappend html-right-item items))
|
||||
|
||||
(define (html-right-item item)
|
||||
(match item
|
||||
['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
|
||||
[('VERBATIM item) item]
|
||||
[(body ...) (list body)]))
|
||||
|
||||
|
||||
(provide make-split-screen
|
||||
make-split-page
|
||||
make-split-page/internal-browser
|
||||
make-simple-page/internal-browser)
|
||||
|
||||
)
|
||||
|
|
@ -1,68 +1,68 @@
|
|||
(module url mzscheme
|
||||
(require "../../private/internal-hp.ss")
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define url-helpdesk-root
|
||||
(string-append
|
||||
"http://" internal-host ":" (number->string internal-port) "/servlets/"))
|
||||
|
||||
(define url-helpdesk-home (string-append url-helpdesk-root "home.ss"))
|
||||
(define url-helpdesk-results (string-append url-helpdesk-root "results.ss"))
|
||||
|
||||
(define (url-home-subpage subpage-str)
|
||||
(string-append url-helpdesk-home "?subpage=" subpage-str))
|
||||
|
||||
(define (version-major)
|
||||
; TODO: Fix this
|
||||
(cond [(regexp-match #px"^(\\d+).*$" (version))
|
||||
=> cadr]
|
||||
[else "352"]))
|
||||
|
||||
(define (url-manual-on-doc-server manual)
|
||||
(string-append
|
||||
"http://download.plt-scheme.org/doc/"
|
||||
(version-major) "/html/" manual "/"))
|
||||
|
||||
(define (url-static 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-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-mailing-list-subscription "http://www.plt-scheme.org/maillist/")
|
||||
(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-planet "http://planet.plt-scheme.org/")
|
||||
|
||||
(define url-helpdesk-acknowledge (url-home-subpage "acknowledge"))
|
||||
(define url-helpdesk-books (url-home-subpage "books"))
|
||||
(define url-helpdesk-documentation (url-home-subpage "documentation"))
|
||||
(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-manual (url-static "doc1" "drscheme" "index.htm"))
|
||||
(define url-helpdesk-faq (url-home-subpage "faq"))
|
||||
(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-known-bugs (url-home-subpage "known-bugs"))
|
||||
(define url-helpdesk-languages (url-home-subpage "languages"))
|
||||
(define url-helpdesk-libraries (url-home-subpage "libraries"))
|
||||
(define url-helpdesk-license (url-home-subpage "license"))
|
||||
(define url-helpdesk-manuals (url-home-subpage "manuals"))
|
||||
(define url-helpdesk-mailing-lists (url-home-subpage "mailing-lists"))
|
||||
(define url-helpdesk-mzlib (url-static "doc1" "mzlib" "mzlib.html"))
|
||||
(define url-helpdesk-patches (url-home-subpage "patches"))
|
||||
(define url-helpdesk-program-design (url-home-subpage "program-design"))
|
||||
(define url-helpdesk-release (url-home-subpage "release"))
|
||||
(define url-helpdesk-release-notes (url-home-subpage "release-notes"))
|
||||
(define url-helpdesk-search (url-home-subpage "search"))
|
||||
(define url-helpdesk-software (url-home-subpage "software"))
|
||||
(define url-helpdesk-teachpacks (url-home-subpage "teachpacks"))
|
||||
(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-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-tour (url-home-subpage "tour"))
|
||||
(define url-helpdesk-why-drscheme (url-home-subpage "why-drscheme"))
|
||||
|
||||
(module url mzscheme
|
||||
(require "../../private/internal-hp.ss")
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define url-helpdesk-root
|
||||
(string-append
|
||||
"http://" internal-host ":" (number->string internal-port) "/servlets/"))
|
||||
|
||||
(define url-helpdesk-home (string-append url-helpdesk-root "home.ss"))
|
||||
(define url-helpdesk-results (string-append url-helpdesk-root "results.ss"))
|
||||
|
||||
(define (url-home-subpage subpage-str)
|
||||
(string-append url-helpdesk-home "?subpage=" subpage-str))
|
||||
|
||||
(define (version-major)
|
||||
; TODO: Fix this
|
||||
(cond [(regexp-match #px"^(\\d+).*$" (version))
|
||||
=> cadr]
|
||||
[else "352"]))
|
||||
|
||||
(define (url-manual-on-doc-server manual)
|
||||
(string-append
|
||||
"http://download.plt-scheme.org/doc/"
|
||||
(version-major) "/html/" manual "/"))
|
||||
|
||||
(define (url-static 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-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-mailing-list-subscription "http://www.plt-scheme.org/maillist/")
|
||||
(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-planet "http://planet.plt-scheme.org/")
|
||||
|
||||
(define url-helpdesk-acknowledge (url-home-subpage "acknowledge"))
|
||||
(define url-helpdesk-books (url-home-subpage "books"))
|
||||
(define url-helpdesk-documentation (url-home-subpage "documentation"))
|
||||
(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-manual (url-static "doc1" "drscheme" "index.htm"))
|
||||
(define url-helpdesk-faq (url-home-subpage "faq"))
|
||||
(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-known-bugs (url-home-subpage "known-bugs"))
|
||||
(define url-helpdesk-languages (url-home-subpage "languages"))
|
||||
(define url-helpdesk-libraries (url-home-subpage "libraries"))
|
||||
(define url-helpdesk-license (url-home-subpage "license"))
|
||||
(define url-helpdesk-manuals (url-home-subpage "manuals"))
|
||||
(define url-helpdesk-mailing-lists (url-home-subpage "mailing-lists"))
|
||||
(define url-helpdesk-mzlib (url-static "doc1" "mzlib" "mzlib.html"))
|
||||
(define url-helpdesk-patches (url-home-subpage "patches"))
|
||||
(define url-helpdesk-program-design (url-home-subpage "program-design"))
|
||||
(define url-helpdesk-release (url-home-subpage "release"))
|
||||
(define url-helpdesk-release-notes (url-home-subpage "release-notes"))
|
||||
(define url-helpdesk-search (url-home-subpage "search"))
|
||||
(define url-helpdesk-software (url-home-subpage "software"))
|
||||
(define url-helpdesk-teachpacks (url-home-subpage "teachpacks"))
|
||||
(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-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-tour (url-home-subpage "tour"))
|
||||
(define url-helpdesk-why-drscheme (url-home-subpage "why-drscheme"))
|
||||
|
||||
)
|
||||
|
|
@ -1,124 +1,124 @@
|
|||
; Serve static documentation.
|
||||
; 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)
|
||||
|
||||
(module static mzscheme
|
||||
(require (lib "private/mime-types.ss" "web-server")
|
||||
(lib "servlet.ss" "web-server")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "match.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "dirs.ss" "setup")
|
||||
(lib "port.ss")
|
||||
"../private/standard-urls.ss"
|
||||
"../private/docpos.ss"
|
||||
"private/platform.ss"
|
||||
"private/html.ss")
|
||||
|
||||
(provide interface-version timeout start)
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
;;;
|
||||
;;; PORT UTILS
|
||||
;;;
|
||||
|
||||
(define (port->string port)
|
||||
(let ([os (open-output-string)])
|
||||
(copy-port port os)
|
||||
(get-output-string os)))
|
||||
|
||||
(define (file->string path)
|
||||
(call-with-input-file path
|
||||
port->string))
|
||||
|
||||
(define (port->bytes port)
|
||||
(let ([ob (open-output-bytes)])
|
||||
(copy-port port ob)
|
||||
(get-output-bytes ob)))
|
||||
|
||||
(define (file->bytes path)
|
||||
(call-with-input-file path
|
||||
port->bytes))
|
||||
|
||||
;;;
|
||||
;;; MIME
|
||||
;;;
|
||||
|
||||
; get-mime-type : path -> string
|
||||
(define get-mime-type
|
||||
(;make-get-mime-type
|
||||
make-path->mime-type
|
||||
(build-path (find-collects-dir)
|
||||
"web-server" "default-web-root" "mime.types")))
|
||||
|
||||
|
||||
(define (text-mime-type? file-path)
|
||||
(regexp-match #rx"^text"
|
||||
(get-mime-type file-path)))
|
||||
|
||||
;;;
|
||||
;;; URL
|
||||
;;;
|
||||
|
||||
; file-parts->file : string (list string) -> string
|
||||
; (list "foo" "bar" "baz") => "foo/bar/baz"
|
||||
(define (file-parts->file manual fs)
|
||||
(apply string-append
|
||||
(let loop ([fs (cons manual fs)])
|
||||
(cond
|
||||
[(null? fs) (list "")]
|
||||
[(null? (cdr fs)) (list (car fs))]
|
||||
[else (cons (string-append (car fs) "/")
|
||||
(loop (cdr fs)))]))))
|
||||
|
||||
;;;
|
||||
;;; TITLES
|
||||
;;;
|
||||
|
||||
(define (short->manual-title s)
|
||||
(match (assoc (string->path s) known-docs)
|
||||
[#f "Documentation"]
|
||||
[(path . long) long]))
|
||||
|
||||
(define (start request)
|
||||
(with-errors-to-browser
|
||||
send/finish
|
||||
(lambda ()
|
||||
(let* ([bindings (request-bindings request)]
|
||||
[file (get-binding bindings 'file "no file")]
|
||||
[host (get-binding bindings 'host "no host")]
|
||||
|
||||
[url (request-uri request)])
|
||||
(let-values
|
||||
([(file-path host manual)
|
||||
(match (map path/param-path (url-path url))
|
||||
[("servlets" "static.ss" host manual . file-parts)
|
||||
(values (host+file->path host (file-parts->file manual file-parts))
|
||||
host
|
||||
manual)])])
|
||||
(cond
|
||||
[(not file-path)
|
||||
(list #"text/html"
|
||||
"<html><head><title>Not found</title></head><body>File not found.</body></html>")]
|
||||
[(and (file-exists? file-path)
|
||||
(text-mime-type? file-path))
|
||||
(list (get-mime-type file-path)
|
||||
(string-append (xexpr->string
|
||||
(html-page
|
||||
#:title (short->manual-title manual)
|
||||
#:top (case (current-helpdesk-platform)
|
||||
[(internal-browser) '()]
|
||||
[(internal-browser-simple) '()]
|
||||
[else (html-top request)])
|
||||
#:body " "))
|
||||
(file->string file-path)))]
|
||||
[(file-exists? file-path)
|
||||
(list (get-mime-type file-path)
|
||||
(file->bytes file-path))]
|
||||
[else
|
||||
(list #"text/html"
|
||||
(format "<html><head><title>Not found</title></head><body>File not found: ~a</body></html>"
|
||||
file-path))]))))))
|
||||
|
||||
; Serve static documentation.
|
||||
; 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)
|
||||
|
||||
(module static mzscheme
|
||||
(require (lib "private/mime-types.ss" "web-server")
|
||||
(lib "servlet.ss" "web-server")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "match.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "dirs.ss" "setup")
|
||||
(lib "port.ss")
|
||||
"../private/standard-urls.ss"
|
||||
"../private/docpos.ss"
|
||||
"private/platform.ss"
|
||||
"private/html.ss")
|
||||
|
||||
(provide interface-version timeout start)
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
;;;
|
||||
;;; PORT UTILS
|
||||
;;;
|
||||
|
||||
(define (port->string port)
|
||||
(let ([os (open-output-string)])
|
||||
(copy-port port os)
|
||||
(get-output-string os)))
|
||||
|
||||
(define (file->string path)
|
||||
(call-with-input-file path
|
||||
port->string))
|
||||
|
||||
(define (port->bytes port)
|
||||
(let ([ob (open-output-bytes)])
|
||||
(copy-port port ob)
|
||||
(get-output-bytes ob)))
|
||||
|
||||
(define (file->bytes path)
|
||||
(call-with-input-file path
|
||||
port->bytes))
|
||||
|
||||
;;;
|
||||
;;; MIME
|
||||
;;;
|
||||
|
||||
; get-mime-type : path -> string
|
||||
(define get-mime-type
|
||||
(;make-get-mime-type
|
||||
make-path->mime-type
|
||||
(build-path (find-collects-dir)
|
||||
"web-server" "default-web-root" "mime.types")))
|
||||
|
||||
|
||||
(define (text-mime-type? file-path)
|
||||
(regexp-match #rx"^text"
|
||||
(get-mime-type file-path)))
|
||||
|
||||
;;;
|
||||
;;; URL
|
||||
;;;
|
||||
|
||||
; file-parts->file : string (list string) -> string
|
||||
; (list "foo" "bar" "baz") => "foo/bar/baz"
|
||||
(define (file-parts->file manual fs)
|
||||
(apply string-append
|
||||
(let loop ([fs (cons manual fs)])
|
||||
(cond
|
||||
[(null? fs) (list "")]
|
||||
[(null? (cdr fs)) (list (car fs))]
|
||||
[else (cons (string-append (car fs) "/")
|
||||
(loop (cdr fs)))]))))
|
||||
|
||||
;;;
|
||||
;;; TITLES
|
||||
;;;
|
||||
|
||||
(define (short->manual-title s)
|
||||
(match (assoc (string->path s) known-docs)
|
||||
[#f "Documentation"]
|
||||
[(path . long) long]))
|
||||
|
||||
(define (start request)
|
||||
(with-errors-to-browser
|
||||
send/finish
|
||||
(lambda ()
|
||||
(let* ([bindings (request-bindings request)]
|
||||
[file (get-binding bindings 'file "no file")]
|
||||
[host (get-binding bindings 'host "no host")]
|
||||
|
||||
[url (request-uri request)])
|
||||
(let-values
|
||||
([(file-path host manual)
|
||||
(match (map path/param-path (url-path url))
|
||||
[("servlets" "static.ss" host manual . file-parts)
|
||||
(values (host+file->path host (file-parts->file manual file-parts))
|
||||
host
|
||||
manual)])])
|
||||
(cond
|
||||
[(not file-path)
|
||||
(list #"text/html"
|
||||
"<html><head><title>Not found</title></head><body>File not found.</body></html>")]
|
||||
[(and (file-exists? file-path)
|
||||
(text-mime-type? file-path))
|
||||
(list (get-mime-type file-path)
|
||||
(string-append (xexpr->string
|
||||
(html-page
|
||||
#:title (short->manual-title manual)
|
||||
#:top (case (current-helpdesk-platform)
|
||||
[(internal-browser) '()]
|
||||
[(internal-browser-simple) '()]
|
||||
[else (html-top request)])
|
||||
#:body " "))
|
||||
(file->string file-path)))]
|
||||
[(file-exists? file-path)
|
||||
(list (get-mime-type file-path)
|
||||
(file->bytes file-path))]
|
||||
[else
|
||||
(list #"text/html"
|
||||
(format "<html><head><title>Not found</title></head><body>File not found: ~a</body></html>"
|
||||
file-path))]))))))
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user