Initial import of unstable with libraries from web-server
svn: r16609
This commit is contained in:
Jay McCarthy
parent
ab78a3ec0c
commit
5877133df6
19
collects/unstable/bytes.ss
Normal file
19
collects/unstable/bytes.ss
Normal file
|
|
@ -0,0 +1,19 @@
|
||||||
|
#lang scheme
|
||||||
|
(require scheme/serialize)
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[read/bytes (bytes? . -> . serializable?)]
|
||||||
|
[write/bytes (serializable? . -> . bytes?)]
|
||||||
|
[bytes-ci=? (bytes? bytes? . -> . boolean?)])
|
||||||
|
|
||||||
|
(define (bytes-ci=? b0 b1)
|
||||||
|
(string-ci=? (bytes->string/utf-8 b0)
|
||||||
|
(bytes->string/utf-8 b1)))
|
||||||
|
|
||||||
|
(define (read/bytes bs)
|
||||||
|
(read (open-input-bytes bs)))
|
||||||
|
|
||||||
|
(define (write/bytes v)
|
||||||
|
(define by (open-output-bytes))
|
||||||
|
(write v by)
|
||||||
|
(get-output-bytes by))
|
||||||
15
collects/unstable/contract.ss
Normal file
15
collects/unstable/contract.ss
Normal file
|
|
@ -0,0 +1,15 @@
|
||||||
|
#lang scheme
|
||||||
|
|
||||||
|
(define path-element?
|
||||||
|
(or/c path-string? (symbols 'up 'same)))
|
||||||
|
|
||||||
|
(define port-number? (between/c 1 65535))
|
||||||
|
|
||||||
|
(define non-empty-string/c
|
||||||
|
(and/c string?
|
||||||
|
(lambda (s) (not (zero? (string-length s))))))
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[non-empty-string/c contract?]
|
||||||
|
[path-element? contract?]
|
||||||
|
[port-number? contract?])
|
||||||
20
collects/unstable/exn.ss
Normal file
20
collects/unstable/exn.ss
Normal file
|
|
@ -0,0 +1,20 @@
|
||||||
|
#lang scheme/base
|
||||||
|
(require mzlib/contract)
|
||||||
|
|
||||||
|
;; network-error: symbol string . values -> void
|
||||||
|
;; throws a formatted exn:fail:network
|
||||||
|
(define (network-error src fmt . args)
|
||||||
|
(raise (make-exn:fail:network (format "~a: ~a" src (apply format fmt args))
|
||||||
|
(current-continuation-marks))))
|
||||||
|
|
||||||
|
;; exn->string : (or/c exn any) -> string
|
||||||
|
(define (exn->string exn)
|
||||||
|
(if (exn? exn)
|
||||||
|
(parameterize ([current-error-port (open-output-string)])
|
||||||
|
((error-display-handler) (exn-message exn) exn)
|
||||||
|
(get-output-string (current-error-port)))
|
||||||
|
(format "~s\n" exn)))
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[network-error ((symbol? string?) (listof any/c) . ->* . (void))]
|
||||||
|
[exn->string ((or/c exn? any/c) . -> . string?)])
|
||||||
3
collects/unstable/info.ss
Normal file
3
collects/unstable/info.ss
Normal file
|
|
@ -0,0 +1,3 @@
|
||||||
|
#lang setup/infotab
|
||||||
|
(define scribblings
|
||||||
|
'(("scribblings/unstable.scrbl" (multi-page) (experimental))))
|
||||||
19
collects/unstable/list.ss
Normal file
19
collects/unstable/list.ss
Normal file
|
|
@ -0,0 +1,19 @@
|
||||||
|
#lang scheme
|
||||||
|
|
||||||
|
; list-prefix : list? list? -> (or/c list? false/c)
|
||||||
|
; Is l a prefix or r?, and what is that prefix?
|
||||||
|
(define (list-prefix? ls rs)
|
||||||
|
(match ls
|
||||||
|
[(list)
|
||||||
|
#t]
|
||||||
|
[(list-rest l0 ls)
|
||||||
|
(match rs
|
||||||
|
[(list)
|
||||||
|
#f]
|
||||||
|
[(list-rest r0 rs)
|
||||||
|
(if (equal? l0 r0)
|
||||||
|
(list-prefix? ls rs)
|
||||||
|
#f)])]))
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[list-prefix? (list? list? . -> . boolean?)])
|
||||||
44
collects/unstable/net/url.ss
Normal file
44
collects/unstable/net/url.ss
Normal file
|
|
@ -0,0 +1,44 @@
|
||||||
|
#lang scheme/base
|
||||||
|
(require scheme/list
|
||||||
|
scheme/contract
|
||||||
|
net/url)
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[url-replace-path (((listof path/param?) . -> . (listof path/param?)) url? . -> . url?)]
|
||||||
|
[url-path->string ((listof path/param?) . -> . string?)])
|
||||||
|
|
||||||
|
;; replace-path: (url-path -> url-path) url -> url
|
||||||
|
;; make a new url by replacing the path part of a url with a function
|
||||||
|
;; of the url's old path
|
||||||
|
;; also remove the query
|
||||||
|
(define (url-replace-path proc in-url)
|
||||||
|
(let ([new-path (proc (url-path in-url))])
|
||||||
|
(make-url
|
||||||
|
(url-scheme in-url)
|
||||||
|
(url-user in-url)
|
||||||
|
(url-host in-url)
|
||||||
|
(url-port in-url)
|
||||||
|
(url-path-absolute? in-url)
|
||||||
|
new-path
|
||||||
|
empty
|
||||||
|
(url-fragment in-url))))
|
||||||
|
|
||||||
|
;; ripped this off from url-unit.ss
|
||||||
|
(define (url-path->string strs)
|
||||||
|
(apply string-append
|
||||||
|
(apply append
|
||||||
|
(map (lambda (s) (list "/" (maybe-join-params s)))
|
||||||
|
strs))))
|
||||||
|
|
||||||
|
;; needs to unquote things!
|
||||||
|
(define (maybe-join-params s)
|
||||||
|
(if (string? s)
|
||||||
|
s
|
||||||
|
(let ([s (path/param-path s)])
|
||||||
|
(if (string? s)
|
||||||
|
s
|
||||||
|
(case s
|
||||||
|
[(same) "."]
|
||||||
|
[(up) ".."]
|
||||||
|
[else (error 'maybe-join-params
|
||||||
|
"bad value from path/param-path: ~e" s)])))))
|
||||||
53
collects/unstable/path.ss
Normal file
53
collects/unstable/path.ss
Normal file
|
|
@ -0,0 +1,53 @@
|
||||||
|
#lang scheme
|
||||||
|
(require unstable/list
|
||||||
|
unstable/contract)
|
||||||
|
|
||||||
|
; explode-path* : path? -> (listof path?)
|
||||||
|
(define (explode-path* p)
|
||||||
|
(let loop ([p p] [r empty])
|
||||||
|
(cond
|
||||||
|
[(eq? 'relative p) r]
|
||||||
|
[(not p) r]
|
||||||
|
[else
|
||||||
|
(let-values ([(base name dir?) (split-path p)])
|
||||||
|
(loop base (list* name r)))])))
|
||||||
|
|
||||||
|
; strip-prefix-ups : (listof path-element?) -> (listof path-element?)
|
||||||
|
(define (strip-prefix-ups l)
|
||||||
|
(define prefix? (box #t))
|
||||||
|
(filter (lambda (p)
|
||||||
|
(if (unbox prefix?)
|
||||||
|
(if (eq? 'up p)
|
||||||
|
#f
|
||||||
|
(begin #t
|
||||||
|
(set-box! prefix? #f)))
|
||||||
|
#t))
|
||||||
|
l))
|
||||||
|
|
||||||
|
; path-without-base : path? path? -> (listof path-element?)
|
||||||
|
(define (path-without-base base path)
|
||||||
|
(define b (explode-path* base))
|
||||||
|
(define p (explode-path* path))
|
||||||
|
(if (list-prefix? b p)
|
||||||
|
(list-tail p (length b))
|
||||||
|
(error 'path-without-base "~a is not a prefix of ~a" base path)))
|
||||||
|
|
||||||
|
;; build-path-unless-absolute : path-string? path-string? -> path?
|
||||||
|
(define (build-path-unless-absolute base path)
|
||||||
|
(if (absolute-path? path)
|
||||||
|
(build-path path)
|
||||||
|
(build-path base path)))
|
||||||
|
|
||||||
|
(define (directory-part path)
|
||||||
|
(let-values ([(base name must-be-dir) (split-path path)])
|
||||||
|
(cond
|
||||||
|
[(eq? 'relative base) (current-directory)]
|
||||||
|
[(not base) (error 'directory-part "~a is a top-level directory" path)]
|
||||||
|
[(path? base) base])))
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[explode-path* (path-string? . -> . (listof path-element?))]
|
||||||
|
[path-without-base (path-string? path-string? . -> . (listof path-element?))]
|
||||||
|
[strip-prefix-ups ((listof path-element?) . -> . (listof path-element?))]
|
||||||
|
[directory-part (path-string? . -> . path?)]
|
||||||
|
[build-path-unless-absolute (path-string? path-string? . -> . path?)])
|
||||||
25
collects/unstable/scribblings/bytes.scrbl
Normal file
25
collects/unstable/scribblings/bytes.scrbl
Normal file
|
|
@ -0,0 +1,25 @@
|
||||||
|
#lang scribble/doc
|
||||||
|
@(require scribble/base
|
||||||
|
scribble/manual
|
||||||
|
(for-label unstable/bytes
|
||||||
|
scheme/serialize
|
||||||
|
scheme/contract
|
||||||
|
scheme/base))
|
||||||
|
|
||||||
|
@title[#:tag "bytes"]{Bytes}
|
||||||
|
|
||||||
|
@defmodule[unstable/bytes]
|
||||||
|
|
||||||
|
@defproc[(bytes-ci=? [b1 bytes?] [b2 bytes?]) boolean?]{
|
||||||
|
Compares two bytes case insensitively.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(read/bytes [b bytes?])
|
||||||
|
serializable?]{
|
||||||
|
@scheme[read]s a value from @scheme[b] and returns it.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(write/bytes [v serializable?])
|
||||||
|
bytes?]{
|
||||||
|
@scheme[write]s @scheme[v] to a bytes and returns it.
|
||||||
|
}
|
||||||
16
collects/unstable/scribblings/contract.scrbl
Normal file
16
collects/unstable/scribblings/contract.scrbl
Normal file
|
|
@ -0,0 +1,16 @@
|
||||||
|
#lang scribble/doc
|
||||||
|
@(require scribble/base
|
||||||
|
scribble/manual
|
||||||
|
(for-label unstable/contract
|
||||||
|
scheme/contract
|
||||||
|
scheme/base))
|
||||||
|
|
||||||
|
@title[#:tag "contract"]{Contracts}
|
||||||
|
|
||||||
|
@defmodule[unstable/contract]
|
||||||
|
|
||||||
|
@defthing[non-empty-string/c contract?]{Contract for non-empty strings.}
|
||||||
|
|
||||||
|
@defthing[port-number? contract?]{Equivalent to @scheme[(between/c 1 65535)].}
|
||||||
|
|
||||||
|
@defthing[path-element? contract?]{Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].}
|
||||||
22
collects/unstable/scribblings/exn.scrbl
Normal file
22
collects/unstable/scribblings/exn.scrbl
Normal file
|
|
@ -0,0 +1,22 @@
|
||||||
|
#lang scribble/doc
|
||||||
|
@(require scribble/base
|
||||||
|
scribble/manual
|
||||||
|
(for-label unstable/exn
|
||||||
|
scheme/contract
|
||||||
|
scheme/base))
|
||||||
|
|
||||||
|
@title[#:tag "exn"]{Exceptions}
|
||||||
|
|
||||||
|
@defmodule[unstable/exn]
|
||||||
|
|
||||||
|
@defproc[(network-error [s symbol?]
|
||||||
|
[fmt string?]
|
||||||
|
[v any/c] ...)
|
||||||
|
void]{
|
||||||
|
Like @scheme[error], but throws a @scheme[exn:fail:network].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(exn->string [exn (or/c exn? any/c)])
|
||||||
|
string?]{
|
||||||
|
Formats @scheme[exn] with @scheme[(error-display-handler)] as a string.
|
||||||
|
}
|
||||||
16
collects/unstable/scribblings/list.scrbl
Normal file
16
collects/unstable/scribblings/list.scrbl
Normal file
|
|
@ -0,0 +1,16 @@
|
||||||
|
#lang scribble/doc
|
||||||
|
@(require scribble/base
|
||||||
|
scribble/manual
|
||||||
|
(for-label unstable/list
|
||||||
|
scheme/contract
|
||||||
|
scheme/base))
|
||||||
|
|
||||||
|
@title[#:tag "list"]{Lists}
|
||||||
|
|
||||||
|
@defmodule[unstable/list]
|
||||||
|
|
||||||
|
@defproc[(list-prefix? [l list?]
|
||||||
|
[r list?])
|
||||||
|
boolean?]{
|
||||||
|
True if @scheme[l] is a prefix of @scheme[r].
|
||||||
|
}
|
||||||
11
collects/unstable/scribblings/net.scrbl
Normal file
11
collects/unstable/scribblings/net.scrbl
Normal file
|
|
@ -0,0 +1,11 @@
|
||||||
|
#lang scribble/doc
|
||||||
|
@(require scribble/base
|
||||||
|
scribble/manual)
|
||||||
|
|
||||||
|
@title[#:tag "net" #:style 'toc]{Net}
|
||||||
|
|
||||||
|
@defmodule[unstable/net]
|
||||||
|
|
||||||
|
@local-table-of-contents[]
|
||||||
|
|
||||||
|
@include-section["net/url.scrbl"]
|
||||||
23
collects/unstable/scribblings/net/url.scrbl
Normal file
23
collects/unstable/scribblings/net/url.scrbl
Normal file
|
|
@ -0,0 +1,23 @@
|
||||||
|
#lang scribble/doc
|
||||||
|
@(require scribble/base
|
||||||
|
scribble/manual
|
||||||
|
(for-label unstable/net/url
|
||||||
|
net/url
|
||||||
|
scheme/contract
|
||||||
|
scheme/base))
|
||||||
|
|
||||||
|
@title[#:tag "url"]{URLs}
|
||||||
|
|
||||||
|
@defmodule[unstable/net/url]
|
||||||
|
|
||||||
|
@defproc[(url-replace-path [proc ((listof path/param?) . -> . (listof path/param?))]
|
||||||
|
[u url?])
|
||||||
|
url?]{
|
||||||
|
Replaces the URL path of @scheme[u] with @scheme[proc] of the former path.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(url-path->string [url-path (listof path/param?)])
|
||||||
|
string?]{
|
||||||
|
Formats @scheme[url-path] as a string with @scheme["/"] as a delimiter
|
||||||
|
and no params.
|
||||||
|
}
|
||||||
40
collects/unstable/scribblings/path.scrbl
Normal file
40
collects/unstable/scribblings/path.scrbl
Normal file
|
|
@ -0,0 +1,40 @@
|
||||||
|
#lang scribble/doc
|
||||||
|
@(require scribble/base
|
||||||
|
scribble/manual
|
||||||
|
(for-label unstable/path
|
||||||
|
unstable/contract
|
||||||
|
scheme/contract
|
||||||
|
scheme/base))
|
||||||
|
|
||||||
|
@title[#:tag "path"]{Path}
|
||||||
|
|
||||||
|
@defmodule[unstable/path]
|
||||||
|
|
||||||
|
@defproc[(explode-path* [p path-string?])
|
||||||
|
(listof path-element?)]{
|
||||||
|
Like @scheme[normalize-path], but does not resolve symlinks.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(path-without-base [base path-string?]
|
||||||
|
[p path-string?])
|
||||||
|
(listof path-element?)]{
|
||||||
|
Returns, as a list, the portion of @scheme[p] after @scheme[base],
|
||||||
|
assuming @scheme[base] is a prefix of @scheme[p].
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(directory-part [p path-string?])
|
||||||
|
path?]{
|
||||||
|
Returns the directory part of @scheme[p], returning @scheme[(current-directory)]
|
||||||
|
if it is relative.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(build-path-unless-absolute [base path-string?]
|
||||||
|
[p path-string?])
|
||||||
|
path?]{
|
||||||
|
Prepends @scheme[base] to @scheme[p], unless @scheme[p] is absolute.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(strip-prefix-ups [p (listof path-element?)])
|
||||||
|
(listof path-element?)]{
|
||||||
|
Removes all the prefix @scheme[".."]s from @scheme[p].
|
||||||
|
}
|
||||||
26
collects/unstable/scribblings/string.scrbl
Normal file
26
collects/unstable/scribblings/string.scrbl
Normal file
|
|
@ -0,0 +1,26 @@
|
||||||
|
#lang scribble/doc
|
||||||
|
@(require scribble/base
|
||||||
|
scribble/manual
|
||||||
|
(for-label unstable/string
|
||||||
|
scheme/serialize
|
||||||
|
scheme/contract
|
||||||
|
scheme/base))
|
||||||
|
|
||||||
|
@title[#:tag "string"]{Strings}
|
||||||
|
|
||||||
|
@defmodule[unstable/string]
|
||||||
|
|
||||||
|
@defproc[(lowercase-symbol! [sb (or/c string? bytes?)])
|
||||||
|
symbol?]{
|
||||||
|
Returns @scheme[sb] as a lowercase symbol.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(read/string [s string?])
|
||||||
|
serializable?]{
|
||||||
|
@scheme[read]s a value from @scheme[s] and returns it.
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(write/string [v serializable?])
|
||||||
|
string?]{
|
||||||
|
@scheme[write]s @scheme[v] to a string and returns it.
|
||||||
|
}
|
||||||
21
collects/unstable/scribblings/unstable.scrbl
Normal file
21
collects/unstable/scribblings/unstable.scrbl
Normal file
|
|
@ -0,0 +1,21 @@
|
||||||
|
#lang scribble/doc
|
||||||
|
@(require scribble/base
|
||||||
|
scribble/manual)
|
||||||
|
|
||||||
|
@title[#:tag "unstable"]{Unstable}
|
||||||
|
|
||||||
|
@defmodule[unstable]
|
||||||
|
|
||||||
|
This manual documents some of the libraries available in the @schememodname[unstable] collection.
|
||||||
|
|
||||||
|
The name @schememodname[unstable] is intended as a warning that the @bold{interfaces} in particular are unstable. Developers of planet packages and external projects should avoid using modules in the unstable collection. Contracts may change, names may change or disappear, even entire modules may move or disappear without warning to the outside world.
|
||||||
|
|
||||||
|
@local-table-of-contents[]
|
||||||
|
|
||||||
|
@include-section["bytes.scrbl"]
|
||||||
|
@include-section["contract.scrbl"]
|
||||||
|
@include-section["exn.scrbl"]
|
||||||
|
@include-section["list.scrbl"]
|
||||||
|
@include-section["net.scrbl"]
|
||||||
|
@include-section["path.scrbl"]
|
||||||
|
@include-section["string.scrbl"]
|
||||||
22
collects/unstable/string.ss
Normal file
22
collects/unstable/string.ss
Normal file
|
|
@ -0,0 +1,22 @@
|
||||||
|
#lang scheme
|
||||||
|
(require scheme/serialize)
|
||||||
|
|
||||||
|
(define (read/string str)
|
||||||
|
(read (open-input-string str)))
|
||||||
|
(define (write/string v)
|
||||||
|
(define str (open-output-string))
|
||||||
|
(write v str)
|
||||||
|
(get-output-string str))
|
||||||
|
|
||||||
|
; lowercase-symbol! : (or/c string bytes) -> symbol
|
||||||
|
(define (lowercase-symbol! s)
|
||||||
|
(string->symbol
|
||||||
|
(string-downcase
|
||||||
|
(if (bytes? s)
|
||||||
|
(bytes->string/utf-8 s)
|
||||||
|
s))))
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)]
|
||||||
|
[read/string (string? . -> . serializable?)]
|
||||||
|
[write/string (serializable? . -> . string?)])
|
||||||
|
|
@ -1,169 +1,17 @@
|
||||||
#lang scheme/base
|
#lang scheme/base
|
||||||
(require mzlib/list
|
(require unstable/bytes
|
||||||
mzlib/plt-match
|
unstable/contract
|
||||||
mzlib/contract
|
unstable/exn
|
||||||
mzlib/serialize
|
unstable/list
|
||||||
net/url)
|
unstable/path
|
||||||
(define path-element?
|
unstable/string
|
||||||
(or/c path-string? (symbols 'up 'same)))
|
unstable/net/url)
|
||||||
|
(provide
|
||||||
(define port-number? (between/c 1 65535))
|
(all-from-out
|
||||||
|
unstable/bytes
|
||||||
(define non-empty-string/c
|
unstable/contract
|
||||||
(and/c string?
|
unstable/exn
|
||||||
(lambda (s) (not (zero? (string-length s))))))
|
unstable/list
|
||||||
|
unstable/path
|
||||||
(provide/contract
|
unstable/string
|
||||||
[non-empty-string/c contract?]
|
unstable/net/url))
|
||||||
[path-element? contract?]
|
|
||||||
[port-number? contract?]
|
|
||||||
[url-replace-path (((listof path/param?) . -> . (listof path/param?)) url? . -> . url?)]
|
|
||||||
[explode-path* (path-string? . -> . (listof path-element?))]
|
|
||||||
[path-without-base (path-string? path-string? . -> . (listof path-element?))]
|
|
||||||
[list-prefix? (list? list? . -> . boolean?)]
|
|
||||||
[strip-prefix-ups ((listof path-element?) . -> . (listof path-element?))]
|
|
||||||
[url-path->string ((listof path/param?) . -> . string?)]
|
|
||||||
[network-error ((symbol? string?) (listof any/c) . ->* . (void))]
|
|
||||||
[directory-part (path-string? . -> . path?)]
|
|
||||||
[lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)]
|
|
||||||
[exn->string ((or/c exn? any/c) . -> . string?)]
|
|
||||||
[build-path-unless-absolute (path-string? path-string? . -> . path?)]
|
|
||||||
[read/string (string? . -> . serializable?)]
|
|
||||||
[write/string (serializable? . -> . string?)]
|
|
||||||
[read/bytes (bytes? . -> . serializable?)]
|
|
||||||
[write/bytes (serializable? . -> . bytes?)]
|
|
||||||
[bytes-ci=? (bytes? bytes? . -> . boolean?)])
|
|
||||||
|
|
||||||
(define (bytes-ci=? b0 b1)
|
|
||||||
(string-ci=? (bytes->string/utf-8 b0)
|
|
||||||
(bytes->string/utf-8 b1)))
|
|
||||||
|
|
||||||
(define (read/string str)
|
|
||||||
(read (open-input-string str)))
|
|
||||||
(define (write/string v)
|
|
||||||
(define str (open-output-string))
|
|
||||||
(write v str)
|
|
||||||
(get-output-string str))
|
|
||||||
|
|
||||||
(define (read/bytes bs)
|
|
||||||
(read (open-input-bytes bs)))
|
|
||||||
(define (write/bytes v)
|
|
||||||
(define by (open-output-bytes))
|
|
||||||
(write v by)
|
|
||||||
(get-output-bytes by))
|
|
||||||
|
|
||||||
; explode-path* : path? -> (listof path?)
|
|
||||||
(define (explode-path* p)
|
|
||||||
(let loop ([p p] [r empty])
|
|
||||||
(cond
|
|
||||||
[(eq? 'relative p) r]
|
|
||||||
[(not p) r]
|
|
||||||
[else
|
|
||||||
(let-values ([(base name dir?) (split-path p)])
|
|
||||||
(loop base (list* name r)))])))
|
|
||||||
|
|
||||||
; strip-prefix-ups : (listof path-element?) -> (listof path-element?)
|
|
||||||
(define (strip-prefix-ups l)
|
|
||||||
(define prefix? (box #t))
|
|
||||||
(filter (lambda (p)
|
|
||||||
(if (unbox prefix?)
|
|
||||||
(if (eq? 'up p)
|
|
||||||
#f
|
|
||||||
(begin #t
|
|
||||||
(set-box! prefix? #f)))
|
|
||||||
#t))
|
|
||||||
l))
|
|
||||||
|
|
||||||
; list-prefix : list? list? -> (or/c list? false/c)
|
|
||||||
; Is l a prefix or r?, and what is that prefix?
|
|
||||||
(define (list-prefix? ls rs)
|
|
||||||
(match ls
|
|
||||||
[(list)
|
|
||||||
#t]
|
|
||||||
[(list-rest l0 ls)
|
|
||||||
(match rs
|
|
||||||
[(list)
|
|
||||||
#f]
|
|
||||||
[(list-rest r0 rs)
|
|
||||||
(if (equal? l0 r0)
|
|
||||||
(list-prefix? ls rs)
|
|
||||||
#f)])]))
|
|
||||||
|
|
||||||
; path-without-base : path? path? -> (listof path-element?)
|
|
||||||
(define (path-without-base base path)
|
|
||||||
(define b (explode-path* base))
|
|
||||||
(define p (explode-path* path))
|
|
||||||
(if (list-prefix? b p)
|
|
||||||
(list-tail p (length b))
|
|
||||||
(error 'path-without-base "~a is not a prefix of ~a" base path)))
|
|
||||||
|
|
||||||
;; replace-path: (url-path -> url-path) url -> url
|
|
||||||
;; make a new url by replacing the path part of a url with a function
|
|
||||||
;; of the url's old path
|
|
||||||
;; also remove the query
|
|
||||||
(define (url-replace-path proc in-url)
|
|
||||||
(let ([new-path (proc (url-path in-url))])
|
|
||||||
(make-url
|
|
||||||
(url-scheme in-url)
|
|
||||||
(url-user in-url)
|
|
||||||
(url-host in-url)
|
|
||||||
(url-port in-url)
|
|
||||||
(url-path-absolute? in-url)
|
|
||||||
new-path
|
|
||||||
empty
|
|
||||||
(url-fragment in-url))))
|
|
||||||
|
|
||||||
;; ripped this off from url-unit.ss
|
|
||||||
(define (url-path->string strs)
|
|
||||||
(apply string-append
|
|
||||||
(apply append
|
|
||||||
(map (lambda (s) (list "/" (maybe-join-params s)))
|
|
||||||
strs))))
|
|
||||||
|
|
||||||
;; needs to unquote things!
|
|
||||||
(define (maybe-join-params s)
|
|
||||||
(if (string? s)
|
|
||||||
s
|
|
||||||
(let ([s (path/param-path s)])
|
|
||||||
(if (string? s)
|
|
||||||
s
|
|
||||||
(case s
|
|
||||||
[(same) "."]
|
|
||||||
[(up) ".."]
|
|
||||||
[else (error 'maybe-join-params
|
|
||||||
"bad value from path/param-path: ~e" s)])))))
|
|
||||||
|
|
||||||
;; network-error: symbol string . values -> void
|
|
||||||
;; throws a formatted exn:fail:network
|
|
||||||
(define (network-error src fmt . args)
|
|
||||||
(raise (make-exn:fail:network (format "~a: ~a" src (apply format fmt args))
|
|
||||||
(current-continuation-marks))))
|
|
||||||
|
|
||||||
;; build-path-unless-absolute : path-string? path-string? -> path?
|
|
||||||
(define (build-path-unless-absolute base path)
|
|
||||||
(if (absolute-path? path)
|
|
||||||
(build-path path)
|
|
||||||
(build-path base path)))
|
|
||||||
|
|
||||||
;; exn->string : (or/c exn any) -> string
|
|
||||||
(define (exn->string exn)
|
|
||||||
(if (exn? exn)
|
|
||||||
(parameterize ([current-error-port (open-output-string)])
|
|
||||||
((error-display-handler) (exn-message exn) exn)
|
|
||||||
(get-output-string (current-error-port)))
|
|
||||||
(format "~s\n" exn)))
|
|
||||||
|
|
||||||
; lowercase-symbol! : (or/c string bytes) -> symbol
|
|
||||||
(define (lowercase-symbol! s)
|
|
||||||
(string->symbol
|
|
||||||
(string-downcase
|
|
||||||
(if (bytes? s)
|
|
||||||
(bytes->string/utf-8 s)
|
|
||||||
s))))
|
|
||||||
|
|
||||||
(define (directory-part path)
|
|
||||||
(let-values ([(base name must-be-dir) (split-path path)])
|
|
||||||
(cond
|
|
||||||
[(eq? 'relative base) (current-directory)]
|
|
||||||
[(not base) (error 'directory-part "~a is a top-level directory" path)]
|
|
||||||
[(path? base) base])))
|
|
||||||
|
|
@ -17,4 +17,3 @@ Some of these are documented here.
|
||||||
@include-section["mod-map.scrbl"]
|
@include-section["mod-map.scrbl"]
|
||||||
@include-section["url-param.scrbl"]
|
@include-section["url-param.scrbl"]
|
||||||
@include-section["gzip.scrbl"]
|
@include-section["gzip.scrbl"]
|
||||||
@include-section["util.scrbl"]
|
|
||||||
|
|
|
||||||
|
|
@ -1,116 +0,0 @@
|
||||||
#lang scribble/doc
|
|
||||||
@(require "web-server.ss")
|
|
||||||
|
|
||||||
@title[#:tag "util.ss"]{Miscellaneous Utilities}
|
|
||||||
@(require (for-label web-server/private/util
|
|
||||||
net/url
|
|
||||||
scheme/serialize
|
|
||||||
scheme/path))
|
|
||||||
|
|
||||||
@defmodule[web-server/private/util]
|
|
||||||
|
|
||||||
There are a number of other miscellaneous utilities the @web-server
|
|
||||||
needs. They are provided by this module.
|
|
||||||
|
|
||||||
@section{Contracts}
|
|
||||||
@defthing[non-empty-string/c contract?]{Contract for non-empty strings.}
|
|
||||||
@defthing[port-number? contract?]{Equivalent to @scheme[(between/c 1 65535)].}
|
|
||||||
@defthing[path-element? contract?]{Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].}
|
|
||||||
|
|
||||||
@section{Lists}
|
|
||||||
@defproc[(list-prefix? [l list?]
|
|
||||||
[r list?])
|
|
||||||
boolean?]{
|
|
||||||
True if @scheme[l] is a prefix of @scheme[r].
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{URLs}
|
|
||||||
|
|
||||||
@defproc[(url-replace-path [proc ((listof path/param?) . -> . (listof path/param?))]
|
|
||||||
[u url?])
|
|
||||||
url?]{
|
|
||||||
Replaces the URL path of @scheme[u] with @scheme[proc] of the former path.
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(url-path->string [url-path (listof path/param?)])
|
|
||||||
string?]{
|
|
||||||
Formats @scheme[url-path] as a string with @scheme["/"] as a delimiter
|
|
||||||
and no params.
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Paths}
|
|
||||||
@defproc[(explode-path* [p path-string?])
|
|
||||||
(listof path-element?)]{
|
|
||||||
Like @scheme[normalize-path], but does not resolve symlinks.
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(path-without-base [base path-string?]
|
|
||||||
[p path-string?])
|
|
||||||
(listof path-element?)]{
|
|
||||||
Returns, as a list, the portion of @scheme[p] after @scheme[base],
|
|
||||||
assuming @scheme[base] is a prefix of @scheme[p].
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(directory-part [p path-string?])
|
|
||||||
path?]{
|
|
||||||
Returns the directory part of @scheme[p], returning @scheme[(current-directory)]
|
|
||||||
if it is relative.
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(build-path-unless-absolute [base path-string?]
|
|
||||||
[p path-string?])
|
|
||||||
path?]{
|
|
||||||
Prepends @scheme[base] to @scheme[p], unless @scheme[p] is absolute.
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(strip-prefix-ups [p (listof path-element?)])
|
|
||||||
(listof path-element?)]{
|
|
||||||
Removes all the prefix @scheme[".."]s from @scheme[p].
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Exceptions}
|
|
||||||
|
|
||||||
@defproc[(network-error [s symbol?]
|
|
||||||
[fmt string?]
|
|
||||||
[v any/c] ...)
|
|
||||||
void]{
|
|
||||||
Like @scheme[error], but throws a @scheme[exn:fail:network].
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(exn->string [exn (or/c exn? any/c)])
|
|
||||||
string?]{
|
|
||||||
Formats @scheme[exn] with @scheme[(error-display-handler)] as a string.
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Strings}
|
|
||||||
|
|
||||||
@defproc[(lowercase-symbol! [sb (or/c string? bytes?)])
|
|
||||||
symbol?]{
|
|
||||||
Returns @scheme[sb] as a lowercase symbol.
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(read/string [s string?])
|
|
||||||
serializable?]{
|
|
||||||
@scheme[read]s a value from @scheme[s] and returns it.
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(write/string [v serializable?])
|
|
||||||
string?]{
|
|
||||||
@scheme[write]s @scheme[v] to a string and returns it.
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Bytes}
|
|
||||||
|
|
||||||
@defproc[(bytes-ci=? [b1 bytes?] [b2 bytes?]) boolean?]{
|
|
||||||
Compares two bytes case insensitively.
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(read/bytes [b bytes?])
|
|
||||||
serializable?]{
|
|
||||||
@scheme[read]s a value from @scheme[b] and returns it.
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(write/bytes [v serializable?])
|
|
||||||
bytes?]{
|
|
||||||
@scheme[write]s @scheme[v] to a bytes and returns it.
|
|
||||||
}
|
|
||||||
Loading…
Reference in New Issue
Block a user