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

Added top bar to the HelpDesk servlets doc-anchor.ss and doc-content.ss when used by an external browser.

Browse Source 
svn: r7234
This commit is contained in:
Jens Axel Soegaard 2007-08-30 22:02:33 +00:00
parent da4c99f231
commit 37957c8548
6 changed files with 84 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -149,7 +149,7 @@
;; escape colons and other junk
(uri-encode (path->string path))
(uri-encode name)
(format "Documentation for the ~a " name))))
(format "Documentation for ~a " name))))
,(format "~a " name))]
[else
`(font ((color "red"))

3
collects/help/servlets/doc-anchor.ss
View File

@ -12,7 +12,8 @@
[offset (with-handlers ((void (lambda _ #f)))
(string->number
(extract-binding/single 'offset bindings)))])
(read-doc (extract-binding/single 'file bindings)
(read-doc initial-request
(extract-binding/single 'file bindings)
(extract-binding/single 'caption bindings)
(extract-binding/single 'name bindings)
offset))))))

2
collects/help/servlets/doc-content.ss
View File

@ -16,4 +16,4 @@
(string->number
(extract-binding/single 'offset bindings)))])
`(html (head (title "PLT Help Desk") ,hd-css ,@hd-links)
,(read-lines file caption offset)))))))
,(read-lines initial-request file caption offset)))))))

53
collects/help/servlets/private/mime.ss Normal file
View File

@ -0,0 +1,53 @@
(module mime mzscheme
(provide (all-defined))
(require (lib "private/mime-types.ss" "web-server")
(lib "dirs.ss" "setup")
(lib "port.ss")
"../../private/docpos.ss")
;;;
;;; MIME
;;;
; get-mime-type : path -> string
(define get-mime-type
(let ([path->mime-type
(make-path->mime-type
(build-path (find-collects-dir)
"web-server" "default-web-root" "mime.types"))])
(lambda (file)
(path->mime-type
(if (string? file)
(string->path file)
file)))))
(define (text-mime-type? file-path)
(regexp-match #rx"^text"
(get-mime-type file-path)))
;;;
;;; 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))
)

37
collects/help/servlets/private/read-doc.ss
View File

@ -1,28 +1,39 @@
(module read-doc mzscheme
(require (lib "etc.ss")
(lib "getinfo.ss" "setup")
(lib "xml.ss" "xml")
"../../private/options.ss"
"util.ss"
"read-lines.ss"
"html.ss")
"html.ss"
"mime.ss")
(provide read-doc)
;; extracts help desk message
(define (get-message coll)
(with-handlers ([void (lambda _ #f)]) ; collection may not exist
((get-info (list coll)) 'help-desk-message (lambda () #f))))
(define offset-format "file=~a&caption=~a&offset=~a#temp")
(define (build-page file caption coll offset)
(let ([msg (get-message coll)])
(html-page
#:title "PLT Help Desk"
#:bodies (if msg
`(,(format-collection-message msg)
(hr)
,(read-lines file caption offset))
`(,(read-lines file caption offset))))))
(define (build-page request file-path caption coll offset)
(html-page
#:title (if (string? caption) caption "Documentation")
#:top (case (helpdesk-platform)
[(internal-browser internal-browser-simple) '()]
[else (html-top request)])
#:body
(let ([msg (get-message coll)])
(cond
[(not file-path)
(format "File not found.")]
[(file-exists? file-path)
(if msg
`(div (p ,msg) ,(read-lines file-path caption offset))
(read-lines file-path caption offset))]
[else
(format "File not found: ~a" file-path)]))))
(define read-doc
(opt-lambda (file caption coll [offset #f])
(build-page file caption coll offset))))
(opt-lambda (request file caption coll [offset #f])
(build-page request file caption coll offset))))

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

@ -3,59 +3,20 @@
;; (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")
(require (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/options.ss"
"private/html.ss")
"private/html.ss"
"private/mime.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
@ -88,7 +49,6 @@
(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)