113 lines
4.2 KiB
Scheme
113 lines
4.2 KiB
Scheme
(module standard-urls mzscheme
|
|
|
|
(require "../servlets/private/util.ss"
|
|
"internal-hp.ss"
|
|
(lib "contract.ss"))
|
|
|
|
(provide home-page-url)
|
|
|
|
(define (search-type? x)
|
|
(member x '("keyword" "keyword-index" "keyword-index-text")))
|
|
|
|
(define (search-how? x)
|
|
(member x '("exact-match" "containing-match" "regexp-match")))
|
|
|
|
(provide search-type? search-how?)
|
|
(provide/contract
|
|
(make-relative-results-url (string?
|
|
search-type?
|
|
search-how?
|
|
any/c
|
|
(listof path?)
|
|
any/c
|
|
(union false/c string?) . -> . string?))
|
|
(make-results-url (string?
|
|
search-type? search-how? any/c
|
|
(listof path?)
|
|
any/c
|
|
(union false/c string?)
|
|
. -> .
|
|
string?))
|
|
(flush-manuals-url string?)
|
|
(flush-manuals-path string?)
|
|
(make-missing-manual-url (string? string? string? string? . -> . string?))
|
|
(get-hd-location ((lambda (sym) (memq sym hd-location-syms))
|
|
. -> .
|
|
string))
|
|
[make-docs-plt-url (string? . -> . string?)]
|
|
[make-docs-html-url (string? . -> . string?)])
|
|
|
|
(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 cookie 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 cookie coll name link)
|
|
(format "http://~a:~a/servlets/missing-manual.ss?manual=~a&name=~a&link=~a"
|
|
internal-host
|
|
internal-port
|
|
coll
|
|
(hexify-string name)
|
|
(hexify-string 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")
|
|
(hexify-string search-string)
|
|
search-type
|
|
match-type
|
|
(if lucky? "true" "false")
|
|
(hexify-string (format "~s" (map path->bytes manuals)))
|
|
(if doc.txt? "true" "false"))])
|
|
(if language-name
|
|
(string-append start (format "&langname=~a" (hexify-string language-name)))
|
|
start)))
|
|
|
|
; sym, string assoc list
|
|
(define hd-locations
|
|
'((hd-tour "/doc/tour/")
|
|
(release-notes "/servlets/release/notes.ss")
|
|
(plt-license "/servlets/release/license.ss")
|
|
(front-page "/servlets/home.ss")))
|
|
|
|
(define hd-location-syms (map car hd-locations))
|
|
|
|
(define (get-hd-location sym)
|
|
; the assq is guarded by the contract
|
|
(let ([entry (assq sym hd-locations)])
|
|
(prefix-with-server (cadr entry)))))
|