" '(p)] + [(title . path) (mk-link path title)]) + (let loop ([breaks (sec-seps sec)] + [names+paths names+paths]) + (cond + [(null? breaks) names+paths] + [else + (let ([break (car breaks)]) + (loop (cdr breaks) + (break-between (car breaks) names+paths)))]))))))) + + ;; break-between : regexp + ;; (listof (union string (cons string string))) + ;; -> (listof (union string (cons string string))) + ;; adds the para-mark string into the list at the first place + ;; that the regexp fails to match (not counting other para-marks + ;; in the list) + (define (break-between re l) + (let ([para-mark "
"]) + (let loop ([l l]) + (cond + [(null? l) null] + [else + (let ([fst (car l)]) + (cond + [(pair? fst) + (let ([name (car fst)]) + (if (regexp-match re name) + (cons para-mark l) + (cons fst (loop (cdr l)))))] + [else (cons fst (loop (cdr l)))]))])))) + + + ;; mk-link : string string -> xexpr + (define (mk-link doc-path name) + (let* ([manual-name (basename doc-path)] + [index-file (get-index-file doc-path)]) + `(li (a ((href ,(get-help-url (build-path doc-path index-file)))) + ,name) + ,@(cond + [(and (repos-or-nightly-build?) + (file-exists? (build-path doc-path index-file))) + `((br) + 'nbsp + 'nbsp + (font ((size "-1")) + ,@(if (is-known-doc? doc-path) + (list + "[" + `(a ((mzscheme + ,(to-string/escape-quotes + `((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals) + (list (cons ((dynamic-require '(lib "refresh-manuals.ss" "help") 'bytes-to-path) + ,(path->bytes manual-name)) + ,name)))))) + ,(string-constant plt:hd:refresh)) + "]" 'nbsp) + (list))))] + [else + (list + (format (string-constant plt:hd:manual-installed-date) + (date->string + (seconds->date + (file-or-directory-modify-seconds + (build-path doc-path index-file))))))])))) + + (define (to-string/escape-quotes exp) + (regexp-replace* #rx"\"" (format "~s" exp) "|")) + + ;; get-doc-name : path -> string + (define cached-doc-names (make-hash-table 'equal)) + (define (get-doc-name doc-dir) + (hash-table-get cached-doc-names doc-dir + (lambda () + (let ([res (compute-doc-name doc-dir)]) + (hash-table-put! cached-doc-names doc-dir res) + res)))) + + ;; compute-doc-name : path -> string[title of manual] + ;; gets the title either from the known docs list, by parsing the + ;; html, or if both those fail, by using the name of the directory + ;; Special-cases the help collection. It's not a known doc directory + ;; per se, so it won't appear in known-docs, but its name is always + ;; the same. + (define (compute-doc-name doc-dir) + (let ([doc-short-dir-name (basename doc-dir)]) + (cond + [(equal? (string->path "help") doc-short-dir-name) "PLT Help Desk"] + [(get-known-doc-name doc-dir) => values] + [else (let* ([main-file (get-index-file doc-dir)] + [m (and main-file + (call-with-input-file (build-path doc-dir main-file) + (lambda (inp) (regexp-match re:title inp))))]) + (if m + (bytes->string/utf-8 (cadr m)) + (path->string doc-short-dir-name)))]))) + (define re:title + #rx"<[tT][iI][tT][lL][eE]>[ \t\r\n]*(.*?)[ \t\r\n]*") + + ;; is-known-doc? : string[path] -> boolean + (define (is-known-doc? doc-path) + (and (assoc (basename doc-path) known-docs) #t)) + + ;; get-known-doc-name : string[full-path] -> (union string #f) + (define (get-known-doc-name doc-path) + (cond [(assoc (basename doc-path) known-docs) => cdr] [else #f])) + + ;; get-uninstalled : (listof path) -> (listof (cons path string[docs-name])) + (define (get-uninstalled docs) + (let ([ht (make-hash-table 'equal)]) + (for-each (lambda (known-doc) + (hash-table-put! ht + (car known-doc) + (cdr known-doc))) + known-docs) + (for-each (lambda (doc) (hash-table-remove! ht (basename doc))) docs) + (sort (hash-table-map ht cons) + (λ (a b) (compare-docs (car a) (car b)))))) + + (define (compare-docs a b) + (let ([ap (standard-html-doc-position (basename a))] + [bp (standard-html-doc-position (basename b))]) + (cond [(= ap bp) (stringstring a) (path->string b))] + [else (< ap bp)]))) + + ;; get-manual-index : string -> html + (define (get-manual-index manual-dirname) (get-help-url (build-path (find-doc-dir) manual-dirname))) + + ;; get-index-file : path -> (union #f path) + ;; returns the name of the main file, if one can be found + (define (get-index-file doc-dir) + (cond + [(file-exists? (build-path doc-dir "index.htm")) + (build-path "index.htm")] + [(file-exists? (build-path doc-dir "index.html")) + (build-path "index.html")] + [(tex2page-detected doc-dir) + => + (lambda (x) x)] + [else #f])) + + ;; tex2page-detected : string -> (union #f string) + (define (tex2page-detected dir) + (let loop ([contents (directory-list dir)]) + (cond + [(null? contents) #f] + [else (let* ([file (car contents)] + [m (regexp-match #rx#"(.*)-Z-H-1.html" (path->bytes file))]) + (or (and m + (file-exists? (build-path dir file)) + (let ([index-file + (bytes->path + (bytes-append (cadr m) #".html"))]) + (if (file-exists? (build-path dir index-file)) + index-file + #f))) + (loop (cdr contents))))]))) + + + (provide find-manuals + main-manual-page + finddoc + finddoc-page-anchor) + + (provide/contract [manual-entry (string? string? xexpr? . -> . xexpr?)] + [finddoc-page (string? string? . -> . string?)] + [get-doc-name (path? . -> . string?)] + [find-doc-directories (-> (listof path?))] + [find-doc-directory (path? . -> . (or/c false/c path?))] + [find-doc-names (-> (listof (cons/c path? string?)))] + [get-manual-index (-> string? string?)] + [get-index-file (path? . -> . (or/c false/c path?))])) diff --git a/collects/help/private/options.ss b/collects/help/private/options.ss new file mode 100644 index 0000000000..d3e54d264a --- /dev/null +++ b/collects/help/private/options.ss @@ -0,0 +1,22 @@ +(module options mzscheme + + ;; This module provides configuration options that are shared + ;; between servlets and the web-server. (Mostly to allow + ;; configuration as an application or as a standalone server.) + + (provide helpdesk-platform internal-port) + + ;; internal browser or external browser? + ;; (used to produce simpler html for the internal browser) + (define helpdesk-platform + (make-parameter + 'internal-browser-simple ; main page only + ;; 'internal-browser ; menu + main page + ;; 'external-browser + )) + + ;; Port for the server to listen on + ;; (relevant only for a standalone server) + (define internal-port (make-parameter 8012)) + + ) diff --git a/collects/help/private/path.ss b/collects/help/private/path.ss new file mode 100644 index 0000000000..f842a3ae08 --- /dev/null +++ b/collects/help/private/path.ss @@ -0,0 +1,10 @@ +(module path mzscheme + (require (lib "contract.ss")) + (define (servlet-path? path) + (if (regexp-match #rx#"^/servlets/" + (path->bytes path)) + #t + #f)) + (provide/contract + [servlet-path? (path? . -> . boolean?)])) + diff --git a/collects/help/private/standard-urls.ss b/collects/help/private/standard-urls.ss new file mode 100644 index 0000000000..33a4654597 --- /dev/null +++ b/collects/help/private/standard-urls.ss @@ -0,0 +1,134 @@ +(module standard-urls mzscheme + (require (lib "uri-codec.ss" "net") + (lib "dirs.ss" "setup") + (lib "contract.ss") + (lib "config.ss" "planet") + (lib "help-desk-urls.ss" "help") + "../servlets/private/util.ss" + "internal-hp.ss" + "get-help-url.ss") + + (provide home-page-url host+dirs) + + (define (search-type? x) + (member x '("keyword" "keyword-index" "keyword-index-text"))) + + (define (search-how? x) + (member x '("exact-match" "containing-match" "regexp-match"))) + + (define (base-docs-url) + (if (repos-or-nightly-build?) + "http://pre.plt-scheme.org/docs" + (string-append "http://download.plt-scheme.org/doc/" (version)))) + + (define (make-docs-plt-url manual-name) + (format "~a/bundles/~a-doc.plt" (base-docs-url) manual-name)) + + (define (make-docs-html-url manual-name) + (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)) + + (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 relative-results-url-prefix "/servlets/results.ss?") + + (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) + coll + (uri-encode name) + (uri-encode link))) + + (define (make-relative-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name) + (string-append + relative-results-url-prefix + (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name))) + + (define (make-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name) + (string-append + results-url-prefix + (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name))) + + (define (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? language-name) + (let ([start + (format + (string-append "search-string=~a&" + "search-type=~a&" + "match-type=~a&" + "lucky=~a&" + "manuals=~a&" + "doctxt=~a") + (uri-encode search-string) + search-type + match-type + (if lucky? "true" "false") + (uri-encode (format "~s" (map path->bytes manuals))) + (if doc.txt? "true" "false"))]) + (if language-name + (string-append start (format "&langname=~a" (uri-encode language-name))) + start))) + + ; sym, string assoc list + (define hd-locations + `((hd-tour ,(format "~a/index.html" (get-help-url (build-path (find-doc-dir) "tour")))) + (release-notes ,url-helpdesk-release-notes) + (plt-license ,url-helpdesk-license) + (front-page ,url-helpdesk-home))) + + (define hd-location-syms (map car hd-locations)) + + (define (get-hd-location sym) + ; the assq is guarded by the contract + (cadr (assq sym hd-locations))) + + ; host+dirs : (list (cons host-string dir-path)) + ; association between internal (in normal Helpdesk also virtual) + ; hosts and their corresponding file root. + (define host+dirs + (map cons + (append collects-hosts doc-hosts) + (append collects-dirs doc-dirs))) + + (define (host+file->path host file-path) + (cond [(assoc host host+dirs) + => (lambda (internal-host+path) + (let ([path (cdr internal-host+path)]) + (build-path path file-path)))] + [(equal? host "planet") + (build-path (PLANET-DIR) file-path)] + [else #f])) + + (provide host+file->path) + (provide search-type? search-how?) + (provide/contract + (make-relative-results-url (string? + search-type? + search-how? + any/c + (listof path?) + any/c + (or/c false/c string?) . -> . string?)) + (make-results-url (string? + search-type? search-how? any/c + (listof path?) + any/c + (or/c false/c string?) + . -> . + string?)) + (flush-manuals-url string?) + (flush-manuals-path string?) + (make-missing-manual-url (string? string? string? . -> . string?)) + (get-hd-location ((lambda (sym) (memq sym hd-location-syms)) + . -> . + string?)) + [prefix-with-server (string? . -> . string?)] + [make-docs-plt-url (string? . -> . string?)] + [make-docs-html-url (string? . -> . string?)])) diff --git a/collects/help/servlets/private/url.ss b/collects/help/servlets/private/url.ss new file mode 100644 index 0000000000..27a552a452 --- /dev/null +++ b/collects/help/servlets/private/url.ss @@ -0,0 +1,83 @@ +(module url mzscheme + (require "../../private/internal-hp.ss") + + (provide (all-defined)) + + (define url-helpdesk-root + (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")) + (define url-helpdesk-master-index (string-append url-helpdesk-root "master-index.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) + (format "http://download.plt-scheme.org/doc/~a/html/~a/" + (version-major) manual)) + + (define (url-static doc manual path) + (format "~astatic.ss/~a/~a/~a" + url-helpdesk-root 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-mrflow "http://www.plt-scheme.org/software/mrflow/") + (define url-external-mrspidey "http://www.plt-scheme.org/software/mrspidey/") + (define url-external-mysterx "http://www.plt-scheme.org/software/mysterx/") + (define url-external-mzcom "http://www.plt-scheme.org/software/mzcom/") + (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-external-srpersist "http://www.plt-scheme.org/software/srpersist/") + + (define url-helpdesk-acknowledge (url-home-subpage "acknowledge")) + (define url-helpdesk-batch (url-home-subpage "batch")) + (define url-helpdesk-books (url-home-subpage "books")) + (define url-helpdesk-cgi (url-home-subpage "cgi")) + (define url-helpdesk-databases (url-home-subpage "databases")) + (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-graphics (url-home-subpage "graphics")) + (define url-helpdesk-help (url-home-subpage "help")) + (define url-helpdesk-how-to-search (url-home-subpage "how-to-search")) + (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-script (url-home-subpage "script")) + (define url-helpdesk-search (url-home-subpage "search")) + (define url-helpdesk-software (url-home-subpage "software")) + (define url-helpdesk-srpersist (url-home-subpage "srpersist")) + (define url-helpdesk-stand-alone (url-home-subpage "stand-alone")) + (define url-helpdesk-system (url-home-subpage "system")) + (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")) + + ) diff --git a/collects/help/servlets/private/util.ss b/collects/help/servlets/private/util.ss new file mode 100644 index 0000000000..301316427c --- /dev/null +++ b/collects/help/servlets/private/util.ss @@ -0,0 +1,114 @@ +(module util mzscheme + (require (lib "file.ss") + (lib "list.ss") + (lib "xml.ss" "xml") + (lib "uri-codec.ss" "net") + (lib "string-constant.ss" "string-constants") + (lib "contract.ss")) + + ;; would be nice if this could use version:version from the framework. + (define (plt-version) + (let ([mz-version (version)] + [stamp-collection + (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)]) + (collection-path "repos-time-stamp"))]) + (if (and stamp-collection + (file-exists? (build-path stamp-collection "stamp.ss"))) + (format "~a-svn~a" mz-version + (dynamic-require '(lib "repos-time-stamp/stamp.ss") 'stamp)) + mz-version))) + + (define home-page + `(a ([href "/servlets/home.ss"] [target "_top"]) + ,(string-constant plt:hd:home))) + + (define (get-pref/default pref default) + (get-preference pref (lambda () default))) + + (define (get-bool-pref/default pref default) + (let ([raw-pref (get-pref/default pref default)]) + (if (string=? raw-pref "false") #f #t))) + + (define (put-prefs names vals) + (put-preferences names vals)) + + (define search-height-default "85") + (define search-bg-default "lightsteelblue") + (define search-text-default "black") + (define search-link-default "darkblue") + + (define *the-highlight-color* "forestgreen") + + ;; string xexpr ... -> xexpr + (define (with-color color . s) + `(font ([color ,color]) ,@s)) + + ;; xexpr ... -> xexpr + (define (color-highlight . s) + (apply with-color *the-highlight-color* s)) + + (define repos-or-nightly-build? + (let ([helpdir (collection-path "help")]) + (lambda () + (or (directory-exists? (build-path helpdir ".svn")) + (directory-exists? (build-path helpdir "CVS")) + (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) + (collection-path "repos-time-stamp")))))) + + ; string string -> xexpr + (define (collection-doc-link coll txt) + (let ([coll-file (build-path (collection-path coll) "doc.txt")]) + (if (file-exists? coll-file) + `(a ((href + ,(format + "~a?file=~a&name=~a&caption=Documentation for the ~a collection" + "/servlets/doc-anchor.ss" + (uri-encode (path->string coll-file)) + coll + coll))) + ,txt) + ""))) + + ;; (listof string) -> string + ;; result is forward-slashed web path + ;; e.g. ("foo" "bar") -> "foo/bar" + (define (fold-into-web-path lst) + (foldr (lambda (s a) (if a (string-append s "/" a) s)) #f lst)) + + (define (format-collection-message s) + `(b ((style "color:green")) ,s)) + + (define (make-javascript . ss) + `(script ([language "Javascript"]) + ,(make-comment (apply string-append "\n" + (map (lambda (s) (string-append s "\n")) ss))))) + + (define (redir-javascript k-url) + (make-javascript "function redir() {" + (string-append " document.location.href=\"" k-url "\"") + "}")) + + (define (onload-redir secs) + (string-append "setTimeout(\"redir()\"," + (number->string (* secs 1000)) ")")) + + (provide/contract + [fold-into-web-path ((listof string?) . -> . string?)]) + + (provide get-pref/default + get-bool-pref/default + put-prefs + repos-or-nightly-build? + search-height-default + search-bg-default + search-text-default + search-link-default + color-highlight + with-color + collection-doc-link + home-page + format-collection-message + plt-version + make-javascript + redir-javascript + onload-redir))