135 lines
5.0 KiB
Scheme
135 lines
5.0 KiB
Scheme
(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?)]))
|