215 lines
7.5 KiB
Racket
215 lines
7.5 KiB
Racket
#lang racket/base
|
|
(require racket/contract/base
|
|
racket/list
|
|
unstable/list
|
|
unstable/contract
|
|
racket/serialize
|
|
net/url-structs)
|
|
(require unstable/bytes
|
|
unstable/contract
|
|
unstable/list)
|
|
(provide
|
|
(all-from-out
|
|
unstable/bytes
|
|
unstable/contract
|
|
unstable/list))
|
|
|
|
;; --
|
|
|
|
(define (bytes-ci=? b0 b1)
|
|
(string-ci=? (bytes->string/utf-8 b0)
|
|
(bytes->string/utf-8 b1)))
|
|
;; Eli: If this ever gets in, it should say that the memory requirements
|
|
;; are 4 times the input size, especially since bytes are often used to save
|
|
;; space. Also, fails on (bytes-ci=? #"\277" #"\277"), and a trivial fix
|
|
;; would still fail on (bytes-ci=? #"\276\277" #"\277\276")
|
|
|
|
(provide/contract
|
|
[bytes-ci=? (bytes? bytes? . -> . boolean?)])
|
|
|
|
;; --
|
|
|
|
;; 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?] [] #:rest list? void?)]
|
|
[exn->string (-> any/c string?)])
|
|
|
|
;; --
|
|
|
|
; explode-path* : path? -> (listof path?)
|
|
(define (explode-path* p)
|
|
(let loop ([p p] [r null])
|
|
(cond
|
|
[(eq? 'relative p) r]
|
|
[(not p) r]
|
|
[else
|
|
(let-values ([(base name dir?) (split-path p)])
|
|
(loop base (list* name r)))])))
|
|
;; Eli: We already have `explode-path', this looks like it's doing the
|
|
;; same thing, except a little less useful.
|
|
|
|
; strip-prefix-ups : (listof path-piece?) -> (listof path-piece?)
|
|
(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))
|
|
;; Eli: This is bad. If I understand it correctly, this is what this
|
|
;; *should* have been:
|
|
;; (define (strip-prefix-ups l)
|
|
;; (if (and (pair? l) (eq? 'up (car l))) (strip-prefix-ups (cdr l)) l))
|
|
;; or even:
|
|
;; (define (strip-prefix-ups l)
|
|
;; (match l [(cons 'up l) (strip-prefix-ups l)] [_ l]))
|
|
;; except that the above version manages to combine ugly and
|
|
;; obfuscated code, redundant mutation, redundant code (why is it a
|
|
;; box? why is there a (begin #t ...)?), and being extra slow. Oh,
|
|
;; and if this wasn't enough, there's exactly one place in the web
|
|
;; server that uses it.
|
|
|
|
; path-without-base : path? path? -> (listof path-piece?)
|
|
(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)))
|
|
;; Eli: see my comment on `list-prefix?' -- it would make this trivial.
|
|
;; Also, if you want to look for a useful utility to add, search the code for
|
|
;; `relativize', which is a popular thing that gets written multiple times
|
|
;; and would be nice to have as a library. (But there are some differences
|
|
;; between them, I think.)
|
|
|
|
;; 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)))
|
|
;; Eli: This looks completely unnecessary. I find the code much easier to
|
|
;; understand than the long name.
|
|
|
|
(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])))
|
|
;; Eli: There is now a `file-name-from-path', which suggests that the name for
|
|
;; this should be `directory-name-from-path', but perhaps a new name is
|
|
;; better for both. Also, I find it questionable to return the current
|
|
;; directory in the first case.
|
|
|
|
(provide/contract
|
|
[explode-path* (path-string? . -> . (listof path-piece?))]
|
|
[path-without-base (path-string? path-string? . -> . (listof path-piece?))]
|
|
[strip-prefix-ups ((listof path-piece?) . -> . (listof path-piece?))]
|
|
[directory-part (path-string? . -> . path?)]
|
|
[build-path-unless-absolute (path-string? path-string? . -> . path?)])
|
|
|
|
;; --
|
|
|
|
(define (read/string str)
|
|
(define r (read (open-input-string str)))
|
|
(cond [(eof-object? r) (raise-type-error 'read/string "nonempty string" str)]
|
|
[else r]))
|
|
|
|
;; Eli: Same comments as `read/bytes'.
|
|
|
|
(define (write/string v)
|
|
(define str (open-output-string))
|
|
(write v str)
|
|
(get-output-string str))
|
|
;; Eli: Same comments as `write/string', and worse -- this is the same as
|
|
;; (format "~s" v)
|
|
|
|
; lowercase-symbol! : (or/c string bytes) -> symbol
|
|
(define (lowercase-symbol! s)
|
|
(string->symbol
|
|
(string-downcase
|
|
(if (bytes? s)
|
|
(bytes->string/utf-8 s)
|
|
s))))
|
|
;; Eli: This doesn't make any sense at all. Why is the `!' in the name? Why
|
|
;; does it accept bytes? Why does a function in a "string" library accept
|
|
;; bytes? How can I guess that this creates a new symbol from that name?
|
|
;; (Which makes me think that this is (compose string->symbol string-downcase
|
|
;; symbol->string))
|
|
|
|
(provide/contract
|
|
[lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)]
|
|
[read/string (string? . -> . serializable?)]
|
|
[write/string (serializable? . -> . string?)])
|
|
|
|
;; --
|
|
|
|
(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))))
|
|
;; Eli: if it also removes the query, this it's a bad name, and it's
|
|
;; questionable whether it is general enough. Why not make it into a
|
|
;; keyworded function that can change any part, which sounds like a much more
|
|
;; useful utility? Some `foo' that would allow:
|
|
;; (define (url-replace-path proc in-url)
|
|
;; (foo in-url #:path (proc (url-path in-url)) #:query '()))
|
|
;; or even accept a changing function for all keywords:
|
|
;; (define (url-replace-path proc in-url)
|
|
;; (foo in-url #:path proc #:query '()))
|
|
|
|
;; ripped this off from url-unit.rkt
|
|
(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)])))))
|
|
;; Eli: I don't know what this is supposed to be doing -- I don't see any
|
|
;; "maybe"ness), it throws away the `path/param-param's, and it accepts
|
|
;; strings too (which makes me wonder how is this related to the url
|
|
;; library).
|