62 lines
1.6 KiB
Scheme
62 lines
1.6 KiB
Scheme
#lang scheme
|
|
(require net/url
|
|
scheme/serialize
|
|
web-server/private/servlet
|
|
web-server/stuffers/stuffer
|
|
web-server/stuffers/serialize
|
|
web-server/stuffers/gzip
|
|
web-server/stuffers/base64
|
|
web-server/stuffers/hash
|
|
web-server/http
|
|
web-server/private/url-param)
|
|
|
|
(define (is-url-too-big? v)
|
|
(define uri
|
|
(request-uri
|
|
(execution-context-request
|
|
(current-execution-context))))
|
|
(> (string-length
|
|
(url->string
|
|
(insert-in-uri uri v)))
|
|
; http://www.boutell.com/newfaq/misc/urllength.html
|
|
2048))
|
|
|
|
(define (make-default-stuffer home)
|
|
(stuffer-chain
|
|
serialize-stuffer
|
|
is-url-too-big?
|
|
(stuffer-chain
|
|
gzip-stuffer
|
|
base64-stuffer)
|
|
is-url-too-big?
|
|
(md5-stuffer home)))
|
|
|
|
(define default-stuffer
|
|
(make-default-stuffer
|
|
(build-path (find-system-path 'home-dir) ".urls")))
|
|
|
|
(define URL-KEY "c")
|
|
|
|
(define (insert-in-uri uri c)
|
|
(insert-param uri URL-KEY (bytes->string/utf-8 c)))
|
|
|
|
(define (stuff-url stuffer uri c)
|
|
(insert-in-uri
|
|
uri ((stuffer-in stuffer) c)))
|
|
|
|
(define (stuffed-url? uri)
|
|
(string? (extract-param uri URL-KEY)))
|
|
|
|
(define (unstuff-url stuffer uri)
|
|
((stuffer-out stuffer)
|
|
(string->bytes/utf-8
|
|
(extract-param uri URL-KEY))))
|
|
|
|
(provide/contract
|
|
[default-stuffer (stuffer/c serializable? bytes?)]
|
|
[make-default-stuffer (path-string? . -> . (stuffer/c serializable? bytes?))]
|
|
[is-url-too-big? (bytes? . -> . boolean?)]
|
|
[stuff-url ((stuffer/c serializable? bytes?) url? serializable? . -> . url?)]
|
|
[stuffed-url? (url? . -> . boolean?)]
|
|
[unstuff-url ((stuffer/c serializable? bytes?) url? . -> . serializable?)])
|