suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

dynamic-place now pipes standard io to standard out and error much like system.

Browse Source 
original commit: b6972a3b7f867a187df24bba5718107621e3729f
This commit is contained in:
Kevin Tew 2011-09-07 14:14:49 -06:00
commit 46a7e2ab15
19 changed files with 99 additions and 4557 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/mzlib/include.rkt
View File

@ -20,7 +20,10 @@
fn))
(string->path s))]
[(-build-path elem ...)
(module-or-top-identifier=? #'-build-path build-path-stx)
(begin
(collect-garbage)
(module-identifier=? #'-build-path build-path-stx)
(module-or-top-identifier=? #'-build-path build-path-stx))
(let ([l (syntax-object->datum (syntax (elem ...)))])
(when (null? l)
(raise-syntax-error

34
collects/mzlib/port.rkt
View File

@ -30,40 +30,6 @@
;; ----------------------------------------
(define (copy-port src dest . dests)
(unless (input-port? src)
(raise-type-error 'copy-port "input-port" src))
(for-each
(lambda (dest)
(unless (output-port? dest)
(raise-type-error 'copy-port "output-port" dest)))
(cons dest dests))
(let ([s (make-bytes 4096)]
[dests (cons dest dests)])
(let loop ()
(let ([c (read-bytes-avail! s src)])
(cond
[(number? c)
(let loop ([dests dests])
(unless (null? dests)
(let loop ([start 0])
(unless (= start c)
(let ([c2 (write-bytes-avail s (car dests) start c)])
(loop (+ start c2)))))
(loop (cdr dests))))
(loop)]
[(procedure? c)
(let ([v (let-values ([(l col p) (port-next-location src)])
(c (object-name src) l col p))])
(let loop ([dests dests])
(unless (null? dests)
(write-special v (car dests))
(loop (cdr dests)))))
(loop)]
[else
;; Must be EOF
(void)])))))
(define merge-input
(case-lambda
[(a b) (merge-input a b 4096)]

43
collects/mzlib/process.rkt
View File

@ -8,7 +8,8 @@
system/exit-code
system*/exit-code)
(require mzlib/port)
(require mzlib/port
"private/streams.rkt")
;; Helpers: ----------------------------------------
@ -33,46 +34,6 @@
(format "~a: don't know what shell to use for platform: " who)
(system-type))]))
(define (if-stream-out who p [sym-ok? #f])
(cond [(and sym-ok? (eq? p 'stdout)) p]
[(or (not p) (and (output-port? p) (file-stream-port? p))) p]
[(output-port? p) #f]
[else (raise-type-error who
(if sym-ok?
"output port, #f, or 'stdout"
"output port or #f")
p)]))
(define (if-stream-in who p)
(cond [(or (not p) (and (input-port? p) (file-stream-port? p))) p]
[(input-port? p) #f]
[else (raise-type-error who "input port or #f" p)]))
(define (streamify-in cin in ready-for-break)
(if (and cin (not (file-stream-port? cin)))
(thread (lambda ()
(dynamic-wind
void
(lambda ()
(with-handlers ([exn:break? void])
(ready-for-break #t)
(copy-port cin in)
(ready-for-break #f)))
(lambda () (close-output-port in)))
(ready-for-break #t)))
in))
(define (streamify-out cout out)
(if (and cout
(not (eq? cout 'stdout))
(not (file-stream-port? cout)))
(thread (lambda ()
(dynamic-wind
void
(lambda () (copy-port out cout))
(lambda () (close-input-port out)))))
out))
(define (check-exe who exe)
(unless (path-string? exe)
(raise-type-error who "path or string" exe))

69
collects/net/base64-unit.rkt
View File

@ -1,67 +1,8 @@
#lang racket/unit
#lang racket/base
(require "base64-sig.rkt")
(require racket/unit
"base64-sig.rkt" "base64.rkt")
(import)
(export base64^)
(define-unit-from-context base64@ base64^)
(define ranges '([#"AZ" 0] [#"az" 26] [#"09" 52] [#"++" 62] [#"//" 63]))
(define-values (base64-digit digit-base64)
(let ([bd (make-vector 256 #f)] [db (make-vector 64 #f)])
(for ([r ranges] #:when #t
[i (in-range (bytes-ref (car r) 0) (add1 (bytes-ref (car r) 1)))]
[n (in-naturals (cadr r))])
(vector-set! bd i n)
(vector-set! db n i))
(values (vector->immutable-vector bd) (vector->immutable-vector db))))
(define =byte (bytes-ref #"=" 0))
(define ones
(vector->immutable-vector
(list->vector (for/list ([i (in-range 9)]) (sub1 (arithmetic-shift 1 i))))))
(define (base64-decode-stream in out)
(let loop ([data 0] [bits 0])
(if (>= bits 8)
(let ([bits (- bits 8)])
(write-byte (arithmetic-shift data (- bits)) out)
(loop (bitwise-and data (vector-ref ones bits)) bits))
(let ([c (read-byte in)])
(unless (or (eof-object? c) (eq? c =byte))
(let ([v (vector-ref base64-digit c)])
(if v
(loop (+ (arithmetic-shift data 6) v) (+ bits 6))
(loop data bits))))))))
(define (base64-encode-stream in out [linesep #"\n"])
(let loop ([data 0] [bits 0] [width 0])
(define (write-char)
(write-byte (vector-ref digit-base64 (arithmetic-shift data (- 6 bits)))
out)
(let ([width (modulo (add1 width) 72)])
(when (zero? width) (display linesep out))
width))
(if (>= bits 6)
(let ([bits (- bits 6)])
(loop (bitwise-and data (vector-ref ones bits)) bits (write-char)))
(let ([c (read-byte in)])
(if (eof-object? c)
;; flush extra bits
(begin
(let ([width (if (> bits 0) (write-char) width)])
(when (> width 0)
(for ([i (in-range (modulo (- width) 4))])
(write-byte =byte out))
(display linesep out))))
(loop (+ (arithmetic-shift data 8) c) (+ bits 8) width))))))
(define (base64-decode src)
(let ([s (open-output-bytes)])
(base64-decode-stream (open-input-bytes src) s)
(get-output-bytes s)))
(define (base64-encode src)
(let ([s (open-output-bytes)])
(base64-encode-stream (open-input-bytes src) s (bytes 13 10))
(get-output-bytes s)))
(provide base64@)

1
collects/net/cgi-sig.rkt
View File

@ -20,4 +20,3 @@ get-cgi-method
;; -- general HTML utilities --
string->html
generate-link-text

209
collects/net/cgi-unit.rkt
View File

@ -1,207 +1,8 @@
#lang racket/unit
(require "cgi-sig.rkt" "uri-codec.rkt")
#lang racket/base
(import)
(export cgi^)
(require racket/unit
"cgi-sig.rkt" "cgi.rkt")
;; type bindings = list ((symbol . string))
(define-unit-from-context cgi@ cgi^)
;; --------------------------------------------------------------------
;; Exceptions:
(define-struct cgi-error ())
;; chars : list (char)
;; -- gives the suffix which is invalid, not including the `%'
(define-struct (incomplete-%-suffix cgi-error) (chars))
;; char : char
;; -- an invalid character in a hex string
(define-struct (invalid-%-suffix cgi-error) (char))
;; --------------------------------------------------------------------
;; query-string->string : string -> string
;; -- The input is the string post-processed as per Web specs, which
;; is as follows:
;; spaces are turned into "+"es and lots of things are turned into %XX, where
;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string
;; with all the characters converted back.
(define query-string->string form-urlencoded-decode)
;; string->html : string -> string
;; -- the input is raw text, the output is HTML appropriately quoted
(define (string->html s)
(apply string-append
(map (lambda (c)
(case c
[(#\<) "&lt;"]
[(#\>) "&gt;"]
[(#\&) "&amp;"]
[else (string c)]))
(string->list s))))
(define default-text-color "#000000")
(define default-bg-color "#ffffff")
(define default-link-color "#cc2200")
(define default-vlink-color "#882200")
(define default-alink-color "#444444")
;; generate-html-output :
;; html-string x list (html-string) x ... -> ()
(define (generate-html-output title body-lines
[text-color default-text-color]
[bg-color default-bg-color]
[link-color default-link-color]
[vlink-color default-vlink-color]
[alink-color default-alink-color])
(let ([sa string-append])
(for ([l `("Content-type: text/html"
""
"<html>"
"<!-- The form was processed, and this document was generated,"
" using the CGI utilities for Racket. For more information"
" on Racket, see"
" http://racket-lang.org/"
" and for the CGI utilities, contact"
" (sk@cs.brown.edu). -->"
"<head>"
,(sa "<title>" title "</title>")
"</head>"
""
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
,(sa " link=\"" link-color "\"")
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
""
,@body-lines
""
"</body>"
"</html>")])
(display l)
(newline))))
;; output-http-headers : -> void
(define (output-http-headers)
(printf "Content-type: text/html\r\n\r\n"))
;; delimiter->predicate : symbol -> regexp
;; returns a regexp to read a chunk of text up to a delimiter (excluding it)
(define (delimiter->rx delimiter)
(case delimiter
[(amp) #rx#"^[^&]*"]
[(semi) #rx#"^[^;]*"]
[(amp-or-semi) #rx#"^[^&;]*"]
[else (error 'delimiter->rx
"internal-error, unknown delimiter: ~e" delimiter)]))
;; get-bindings* : iport -> (listof (cons symbol string))
;; Reads all bindings from the input port. The strings are processed to
;; remove the CGI spec "escape"s.
;; This code is _slightly_ lax: it allows an input to end in
;; (current-alist-separator-mode). It's not clear this is legal by the
;; CGI spec, which suggests that the last value binding must end in an
;; EOF. It doesn't look like this matters.
;; ELI: * Keeping this behavior for now, maybe better to remove it?
;; * Looks like `form-urlencoded->alist' is doing almost exactly
;; the same job this code does.
(define (get-bindings* method ip)
(define (err fmt . xs)
(generate-error-output
(list (format "Server generated malformed input for ~a method:" method)
(apply format fmt xs))))
(define value-rx (delimiter->rx (current-alist-separator-mode)))
(define (process str) (query-string->string (bytes->string/utf-8 str)))
(let loop ([bindings '()])
(if (eof-object? (peek-char ip))
(reverse bindings)
(let ()
(define name (car (or (regexp-match #rx"^[^=]+" ip)
(err "Missing field name before `='"))))
(unless (eq? #\= (read-char ip))
(err "No binding for `~a' field." name))
(define value (car (regexp-match value-rx ip)))
(read-char ip) ; consume the delimiter, possibly eof (retested above)
(loop (cons (cons (string->symbol (process name)) (process value))
bindings))))))
;; get-bindings/post : () -> bindings
(define (get-bindings/post)
(get-bindings* "POST" (current-input-port)))
;; get-bindings/get : () -> bindings
(define (get-bindings/get)
(get-bindings* "GET" (open-input-string (getenv "QUERY_STRING"))))
;; get-bindings : () -> bindings
(define (get-bindings)
(if (string=? (get-cgi-method) "POST")
(get-bindings/post)
(get-bindings/get)))
;; generate-error-output : list (html-string) -> <exit>
(define (generate-error-output error-message-lines)
(generate-html-output "Internal Error" error-message-lines)
(exit))
;; bindings-as-html : bindings -> list (html-string)
;; -- formats name-value bindings as HTML appropriate for displaying
(define (bindings-as-html bindings)
`("<code>"
,@(map (lambda (bind)
(string-append (symbol->string (car bind))
"&nbsp;--&gt;&nbsp;"
(cdr bind)
"<br>"))
bindings)
"</code>"))
;; extract-bindings : (string + symbol) x bindings -> list (string)
;; -- Extracts the bindings associated with a given name. The semantics of
;; forms states that a CHECKBOX may use the same NAME field multiple times.
;; Hence, a list of strings is returned. Note that the result may be the
;; empty list.
(define (extract-bindings field-name bindings)
(let ([field-name (if (symbol? field-name)
field-name (string->symbol field-name))])
(let loop ([found null] [bindings bindings])
(if (null? bindings)
found
(if (equal? field-name (caar bindings))
(loop (cons (cdar bindings) found) (cdr bindings))
(loop found (cdr bindings)))))))
;; extract-binding/single : (string + symbol) x bindings -> string
;; -- used in cases where only one binding is supposed to occur
(define (extract-binding/single field-name bindings)
(let* ([field-name (if (symbol? field-name)
field-name (string->symbol field-name))]
[result (extract-bindings field-name bindings)])
(cond
[(null? result)
(generate-error-output
(cons (format "No binding for field `~a':<br>" field-name)
(bindings-as-html bindings)))]
[(null? (cdr result))
(car result)]
[else
(generate-error-output
(cons (format "Multiple bindings for field `~a' where one expected:<br>"
field-name)
(bindings-as-html bindings)))])))
;; get-cgi-method : () -> string
;; -- string is either GET or POST (though future extension is possible)
(define (get-cgi-method)
(or (getenv "REQUEST_METHOD")
(error 'get-cgi-method "no REQUEST_METHOD environment variable")))
;; generate-link-text : string x html-string -> html-string
(define (generate-link-text url anchor-text)
(string-append "<a href=\"" url "\">" anchor-text "</a>"))
(provide cgi@)

340
collects/net/dns-unit.rkt
View File

@ -1,338 +1,8 @@
#lang racket/unit
#lang racket/base
(require "dns-sig.rkt" racket/system racket/udp)
(require racket/unit
"dns-sig.rkt" "dns.rkt")
(import)
(export dns^)
(define-unit-from-context dns@ dns^)
;; UDP retry timeout:
(define INIT-TIMEOUT 50)
(define types
'((a 1)
(ns 2)
(md 3)
(mf 4)
(cname 5)
(soa 6)
(mb 7)
(mg 8)
(mr 9)
(null 10)
(wks 11)
(ptr 12)
(hinfo 13)
(minfo 14)
(mx 15)
(txt 16)))
(define classes
'((in 1)
(cs 2)
(ch 3)
(hs 4)))
(define (cossa i l)
(cond [(null? l) #f]
[(equal? (cadar l) i) (car l)]
[else (cossa i (cdr l))]))
(define (number->octet-pair n)
(list (arithmetic-shift n -8)
(modulo n 256)))
(define (octet-pair->number a b)
(+ (arithmetic-shift a 8) b))
(define (octet-quad->number a b c d)
(+ (arithmetic-shift a 24)
(arithmetic-shift b 16)
(arithmetic-shift c 8)
d))
(define (name->octets s)
(let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))])
(let loop ([s s])
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
(if m
(append (do-one (cadr m)) (loop (caddr m)))
(append (do-one s) (list 0)))))))
(define (make-std-query-header id question-count)
(append (number->octet-pair id)
(list 1 0) ; Opcode & flags (recusive flag set)
(number->octet-pair question-count)
(number->octet-pair 0)
(number->octet-pair 0)
(number->octet-pair 0)))
(define (make-query id name type class)
(append (make-std-query-header id 1)
(name->octets name)
(number->octet-pair (cadr (assoc type types)))
(number->octet-pair (cadr (assoc class classes)))))
(define (add-size-tag m)
(append (number->octet-pair (length m)) m))
(define (rr-data rr)
(cadddr (cdr rr)))
(define (rr-type rr)
(cadr rr))
(define (rr-name rr)
(car rr))
(define (parse-name start reply)
(let ([v (car start)])
(cond
[(zero? v)
;; End of name
(values #f (cdr start))]
[(zero? (bitwise-and #xc0 v))
;; Normal label
(let loop ([len v][start (cdr start)][accum null])
(if (zero? len)
(let-values ([(s start) (parse-name start reply)])
(let ([s0 (list->bytes (reverse accum))])
(values (if s (bytes-append s0 #"." s) s0)
start)))
(loop (sub1 len) (cdr start) (cons (car start) accum))))]
[else
;; Compression offset
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
(cadr start))])
(let-values ([(s ignore-start)
(parse-name (list-tail reply offset) reply)])
(values s (cddr start))))])))
(define (parse-rr start reply)
(let-values ([(name start) (parse-name start reply)])
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
types))]
[start (cddr start)]
;;
[class (car (cossa (octet-pair->number (car start) (cadr start))
classes))]
[start (cddr start)]
;;
[ttl (octet-quad->number (car start) (cadr start)
(caddr start) (cadddr start))]
[start (cddddr start)]
;;
[len (octet-pair->number (car start) (cadr start))]
[start (cddr start)])
;; Extract next len bytes for data:
(let loop ([len len] [start start] [accum null])
(if (zero? len)
(values (list name type class ttl (reverse accum))
start)
(loop (sub1 len) (cdr start) (cons (car start) accum)))))))
(define (parse-ques start reply)
(let-values ([(name start) (parse-name start reply)])
(let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
types))]
[start (cddr start)]
;;
[class (car (cossa (octet-pair->number (car start) (cadr start))
classes))]
[start (cddr start)])
(values (list name type class) start))))
(define (parse-n parse start reply n)
(let loop ([n n][start start][accum null])
(if (zero? n)
(values (reverse accum) start)
(let-values ([(rr start) (parse start reply)])
(loop (sub1 n) start (cons rr accum))))))
(define (dns-query nameserver addr type class)
(unless (assoc type types)
(raise-type-error 'dns-query "DNS query type" type))
(unless (assoc class classes)
(raise-type-error 'dns-query "DNS query class" class))
(let* ([query (make-query (random 256) (string->bytes/latin-1 addr)
type class)]
[udp (udp-open-socket)]
[reply
(dynamic-wind
void
(lambda ()
(let ([s (make-bytes 512)])
(let retry ([timeout INIT-TIMEOUT])
(udp-send-to udp nameserver 53 (list->bytes query))
(sync (handle-evt (udp-receive!-evt udp s)
(lambda (r)
(bytes->list (subbytes s 0 (car r)))))
(handle-evt (alarm-evt (+ (current-inexact-milliseconds)
timeout))
(lambda (v)
(retry (* timeout 2))))))))
(lambda () (udp-close udp)))])
;; First two bytes must match sent message id:
(unless (and (= (car reply) (car query))
(= (cadr reply) (cadr query)))
(error 'dns-query "bad reply id from server"))
(let ([v0 (caddr reply)]
[v1 (cadddr reply)])
;; Check for error code:
(let ([rcode (bitwise-and #xf v1)])
(unless (zero? rcode)
(error 'dns-query "error from server: ~a"
(case rcode
[(1) "format error"]
[(2) "server failure"]
[(3) "name error"]
[(4) "not implemented"]
[(5) "refused"]))))
(let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
[an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
[ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
[ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
(let ([start (list-tail reply 12)])
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
[(ans start) (parse-n parse-rr start reply an-count)]
[(nss start) (parse-n parse-rr start reply ns-count)]
[(ars start) (parse-n parse-rr start reply ar-count)])
(unless (null? start)
(error 'dns-query "error parsing server reply"))
(values (positive? (bitwise-and #x4 v0))
qds ans nss ars reply)))))))
(define cache (make-hasheq))
(define (dns-query/cache nameserver addr type class)
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
(let ([v (hash-ref cache key (lambda () #f))])
(if v
(apply values v)
(let-values ([(auth? qds ans nss ars reply)
(dns-query nameserver addr type class)])
(hash-set! cache key (list auth? qds ans nss ars reply))
(values auth? qds ans nss ars reply))))))
(define (ip->string s)
(format "~a.~a.~a.~a"
(list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
(define (try-forwarding k nameserver)
(let loop ([nameserver nameserver][tried (list nameserver)])
;; Normally the recusion is done for us, but it's technically optional
(let-values ([(v ars auth?) (k nameserver)])
(or v
(and (not auth?)
(let* ([ns (ormap (lambda (ar)
(and (eq? (rr-type ar) 'a)
(ip->string (rr-data ar))))
ars)])
(and ns
(not (member ns tried))
(loop ns (cons ns tried)))))))))
(define (ip->in-addr.arpa ip)
(let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
ip)])
(format "~a.~a.~a.~a.in-addr.arpa"
(list-ref result 4)
(list-ref result 3)
(list-ref result 2)
(list-ref result 1))))
(define (get-ptr-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans))
(define (dns-get-name nameserver ip)
(or (try-forwarding
(lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply)
(dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
(values (and (positive? (length (get-ptr-list-from-ans ans)))
(let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
(let-values ([(name null) (parse-name s reply)])
(bytes->string/latin-1 name))))
ars auth?)))
nameserver)
(error 'dns-get-name "bad ip address")))
(define (get-a-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
ans))
(define (dns-get-address nameserver addr)
(or (try-forwarding
(lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
(values (and (positive? (length (get-a-list-from-ans ans)))
(let ([s (rr-data (car (get-a-list-from-ans ans)))])
(ip->string s)))
ars auth?)))
nameserver)
(error 'dns-get-address "bad address")))
(define (dns-get-mail-exchanger nameserver addr)
(or (try-forwarding
(lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
(values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
(cond
[(null? ans)
(or exchanger
;; Does 'soa mean that the input address is fine?
(and (ormap (lambda (ns) (eq? (rr-type ns) 'soa))
nss)
addr))]
[else
(let ([d (rr-data (car ans))])
(let ([pref (octet-pair->number (car d) (cadr d))])
(if (< pref best-pref)
(let-values ([(name start) (parse-name (cddr d) reply)])
(loop (cdr ans) pref name))
(loop (cdr ans) best-pref exchanger))))]))
ars auth?)))
nameserver)
(error 'dns-get-mail-exchanger "bad address")))
(define (dns-find-nameserver)
(case (system-type)
[(unix macosx)
(with-handlers ([void (lambda (x) #f)])
(with-input-from-file "/etc/resolv.conf"
(lambda ()
(let loop ()
(let ([l (read-line)])
(or (and (string? l)
(let ([m (regexp-match
#rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
l)])
(and m (cadr m))))
(and (not (eof-object? l))
(loop))))))))]
[(windows)
(let ([nslookup (find-executable-path "nslookup.exe" #f)])
(and nslookup
(let-values ([(pin pout pid perr proc)
(apply
values
(process/ports
#f (open-input-file "NUL") (current-error-port)
nslookup))])
(let loop ([name #f] [ip #f] [try-ip? #f])
(let ([line (read-line pin 'any)])
(cond [(eof-object? line)
(close-input-port pin)
(proc 'wait)
(or ip name)]
[(and (not name)
(regexp-match #rx"^Default Server: +(.*)$" line))
=> (lambda (m) (loop (cadr m) #f #t))]
[(and try-ip?
(regexp-match #rx"^Address: +(.*)$" line))
=> (lambda (m) (loop name (cadr m) #f))]
[else (loop name ip #f)]))))))]
[else #f]))
(provide dns@)

211
collects/net/ftp-unit.rkt
View File

@ -1,213 +1,12 @@
#lang racket/unit
#lang racket/base
;; Version 0.2
;; Version 0.1a
;; Micah Flatt
;; 06-06-2002
(require racket/date racket/file racket/port racket/tcp "ftp-sig.rkt")
(import)
(export ftp^)
(require racket/unit
"ftp-sig.rkt" "ftp.rkt")
;; opqaue record to represent an FTP connection:
(define-struct ftp-connection (in out))
(define-unit-from-context ftp@ ftp^)
(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-")
(define re:response-end #rx#"^[0-9][0-9][0-9] ")
(define (check-expected-result line expected)
(when expected
(unless (ormap (lambda (expected)
(bytes=? expected (subbytes line 0 3)))
(if (bytes? expected)
(list expected)
expected))
(error 'ftp "expected result code ~a, got ~a" expected line))))
;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any
;;
;; Checks a standard-format response, checking for the given
;; expected 3-digit result code if expected is not #f.
;;
;; While checking, the function sends response lines to
;; diagnostic-accum. This function -accum functions can return a
;; value that accumulates over multiple calls to the function, and
;; accum-start is used as the initial value. Use `void' and
;; `(void)' to ignore the response info.
;;
;; If an unexpected result is found, an exception is raised, and the
;; stream is left in an undefined state.
(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
(flush-output tcpout)
(let ([line (read-bytes-line tcpin 'any)])
(cond
[(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:multi-response-start line)
(check-expected-result line expected)
(let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
(let loop ([accum (diagnostic-accum line accum-start)])
(let ([line (read-bytes-line tcpin 'any)])
(cond [(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:done line)
(diagnostic-accum line accum)]
[else
(loop (diagnostic-accum line accum))]))))]
[(regexp-match re:response-end line)
(check-expected-result line expected)
(diagnostic-accum line accum-start)]
[else
(error 'ftp "unexpected result: ~e" line)])))
(define (get-month month-bytes)
(cond [(assoc month-bytes
'((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5)
(#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10)
(#"Nov" 11) (#"Dec" 12)))
=> cadr]
[else (error 'get-month "bad month: ~s" month-bytes)]))
(define (bytes->number bytes)
(string->number (bytes->string/latin-1 bytes)))
(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
(define (ftp-make-file-seconds ftp-date-str)
(define date-list (regexp-match re:date (string->bytes/utf-8 ftp-date-str)))
(if (not (list-ref date-list 4))
(find-seconds 0 0 0
(bytes->number (list-ref date-list 6))
(get-month (list-ref date-list 5))
(bytes->number (list-ref date-list 7)))
(let* ([cur-secs (current-seconds)]
[cur-date (seconds->date cur-secs)]
[cur-year (date-year cur-date)]
[tzofs (date-time-zone-offset cur-date)]
[minute (bytes->number (list-ref date-list 4))]
[hour (bytes->number (list-ref date-list 3))]
[day (bytes->number (list-ref date-list 2))]
[month (get-month (list-ref date-list 1))]
[guess (+ (find-seconds 0 minute hour day month cur-year) tzofs)])
(if (guess . <= . cur-secs)
guess
(+ (find-seconds 0 minute hour day month (sub1 cur-year)) tzofs)))))
(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
(define (establish-data-connection tcp-ports)
(fprintf (ftp-connection-out tcp-ports) "PASV\r\n")
(let ([response (ftp-check-response
(ftp-connection-in tcp-ports)
(ftp-connection-out tcp-ports)
#"227"
(lambda (s ignore) s) ; should be the only response
(void))])
(let* ([reg-list (regexp-match re:passive response)]
[pn1 (and reg-list
(bytes->number (list-ref reg-list 5)))]
[pn2 (bytes->number (list-ref reg-list 6))])
(unless (and reg-list pn1 pn2)
(error 'ftp "can't understand PASV response: ~e" response))
(let-values ([(tcp-data tcp-data-out)
(tcp-connect (format "~a.~a.~a.~a"
(list-ref reg-list 1)
(list-ref reg-list 2)
(list-ref reg-list 3)
(list-ref reg-list 4))
(+ (* 256 pn1) pn2))])
(fprintf (ftp-connection-out tcp-ports) "TYPE I\r\n")
(ftp-check-response (ftp-connection-in tcp-ports)
(ftp-connection-out tcp-ports)
#"200" void (void))
(tcp-abandon-port tcp-data-out)
tcp-data))))
;; Used where version 0.1a printed responses:
(define (print-msg s ignore)
;; (printf "~a\n" s)
(void))
(define (ftp-establish-connection* in out username password)
(ftp-check-response in out #"220" print-msg (void))
(fprintf out "USER ~a\r\n" username)
(let ([no-password? (ftp-check-response
in out (list #"331" #"230")
(lambda (line 230?)
(or 230? (regexp-match #rx#"^230" line)))
#f)])
(unless no-password?
(fprintf out "PASS ~a\r\n" password)
(ftp-check-response in out #"230" void (void))))
(make-ftp-connection in out))
(define (ftp-establish-connection server-address server-port username password)
(let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
(ftp-establish-connection* tcpin tcpout username password)))
(define (ftp-close-connection tcp-ports)
(fprintf (ftp-connection-out tcp-ports) "QUIT\r\n")
(ftp-check-response (ftp-connection-in tcp-ports)
(ftp-connection-out tcp-ports)
#"221" void (void))
(close-input-port (ftp-connection-in tcp-ports))
(close-output-port (ftp-connection-out tcp-ports)))
(define (ftp-cd ftp-ports new-dir)
(fprintf (ftp-connection-out ftp-ports) "CWD ~a\r\n" new-dir)
(ftp-check-response (ftp-connection-in ftp-ports)
(ftp-connection-out ftp-ports)
#"250" void (void)))
(define re:dir-line
(regexp (string-append
"^(.)(.*) ((?i:jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec)"
" .* [0-9][0-9]:?[0-9][0-9]) (.*)$")))
(define (ftp-directory-list tcp-ports [path #f])
(define tcp-data (establish-data-connection tcp-ports))
(if path
(fprintf (ftp-connection-out tcp-ports) "LIST ~a\r\n" path)
(fprintf (ftp-connection-out tcp-ports) "LIST\r\n"))
(ftp-check-response (ftp-connection-in tcp-ports)
(ftp-connection-out tcp-ports)
(list #"150" #"125") void (void))
(define lines (port->lines tcp-data))
(close-input-port tcp-data)
(ftp-check-response (ftp-connection-in tcp-ports)
(ftp-connection-out tcp-ports)
#"226" print-msg (void))
(for*/list ([l (in-list lines)]
[m (in-value (cond [(regexp-match re:dir-line l) => cdr]
[else #f]))]
#:when m)
(define size (cond [(and (equal? "-" (car m))
(regexp-match #rx"([0-9]+) *$" (cadr m)))
=> cadr]
[else #f]))
(define r `(,(car m) ,@(cddr m)))
(if size `(,@r ,size) r)))
(define (ftp-download-file tcp-ports folder filename)
;; Save the file under the name tmp.file, rename it once download is
;; complete this assures we don't over write any existing file without
;; having a good file down
(let* ([tmpfile (make-temporary-file
(string-append
(regexp-replace
#rx"~"
(path->string (build-path folder "ftptmp"))
"~~")
"~a"))]
[new-file (open-output-file tmpfile #:exists 'replace)]
[tcp-data (establish-data-connection tcp-ports)])
(fprintf (ftp-connection-out tcp-ports) "RETR ~a\r\n" filename)
(ftp-check-response (ftp-connection-in tcp-ports)
(ftp-connection-out tcp-ports)
(list #"125" #"150") print-msg (void))
(copy-port tcp-data new-file)
(close-output-port new-file)
(close-input-port tcp-data)
(ftp-check-response (ftp-connection-in tcp-ports)
(ftp-connection-out tcp-ports)
#"226" print-msg (void))
(rename-file-or-directory tmpfile (build-path folder filename) #t)))
(provide ftp@)

347
collects/net/head-unit.rkt
View File

@ -1,345 +1,8 @@
#lang racket/unit
#lang racket/base
(require racket/date racket/string "head-sig.rkt")
(require racket/unit
"head-sig.rkt" "head.rkt")
(import)
(export head^)
(define-unit-from-context head@ head^)
;; NB: I've done a copied-code adaptation of a number of these definitions
;; into "bytes-compatible" versions. Finishing the rest will require some
;; kind of interface decision---that is, when you don't supply a header,
;; should the resulting operation be string-centric or bytes-centric?
;; Easiest just to stop here.
;; -- JBC 2006-07-31
(define CRLF (string #\return #\newline))
(define CRLF/bytes #"\r\n")
(define empty-header CRLF)
(define empty-header/bytes CRLF/bytes)
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
(define re:continue (regexp "^[ \t\v]"))
(define re:continue/bytes #rx#"^[ \t\v]")
(define (validate-header s)
(if (bytes? s)
;; legal char check not needed per rfc 2822, IIUC.
(let ([len (bytes-length s)])
(let loop ([offset 0])
(cond
[(and (= (+ offset 2) len)
(bytes=? CRLF/bytes (subbytes s offset len)))
(void)] ; validated
[(= offset len) (error 'validate-header "missing ending CRLF")]
[(or (regexp-match re:field-start/bytes s offset)
(regexp-match re:continue/bytes s offset))
(let ([m (regexp-match-positions #rx#"\r\n" s offset)])
(if m
(loop (cdar m))
(error 'validate-header "missing ending CRLF")))]
[else (error 'validate-header "ill-formed header at ~s"
(subbytes s offset (bytes-length s)))])))
;; otherwise it should be a string:
(begin
(let ([m (regexp-match #rx"[^\000-\377]" s)])
(when m
(error 'validate-header "non-Latin-1 character in string: ~v" (car m))))
(let ([len (string-length s)])
(let loop ([offset 0])
(cond
[(and (= (+ offset 2) len)
(string=? CRLF (substring s offset len)))
(void)] ; validated
[(= offset len) (error 'validate-header "missing ending CRLF")]
[(or (regexp-match re:field-start s offset)
(regexp-match re:continue s offset))
(let ([m (regexp-match-positions #rx"\r\n" s offset)])
(if m
(loop (cdar m))
(error 'validate-header "missing ending CRLF")))]
[else (error 'validate-header "ill-formed header at ~s"
(substring s offset (string-length s)))]))))))
(define (make-field-start-regexp field)
(regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
(define (make-field-start-regexp/bytes field)
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
(define (extract-field field header)
(if (bytes? header)
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
header)])
(and m
(let ([s (subbytes header
(cdaddr m)
(bytes-length header))])
(let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)])
(if m
(subbytes s 0 (caar m))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(regexp-replace #rx#"\r\n\r\n$" s ""))))))
;; otherwise header & field should be strings:
(let ([m (regexp-match-positions (make-field-start-regexp field)
header)])
(and m
(let ([s (substring header
(cdaddr m)
(string-length header))])
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
(if m
(substring s 0 (caar m))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(regexp-replace #rx"\r\n\r\n$" s ""))))))))
(define (replace-field field data header)
(if (bytes? header)
(let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
header)])
(if m
(let* ([pre (subbytes header 0 (caaddr m))]
[s (subbytes header (cdaddr m))]
[m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)])
(bytes-append pre (if data (insert-field field data rest) rest)))
(if data (insert-field field data header) header)))
;; otherwise header & field & data should be strings:
(let ([m (regexp-match-positions (make-field-start-regexp field) header)])
(if m
(let* ([pre (substring header 0 (caaddr m))]
[s (substring header (cdaddr m))]
[m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m (substring s (+ 2 (caar m))) empty-header)])
(string-append pre (if data (insert-field field data rest) rest)))
(if data (insert-field field data header) header)))))
(define (remove-field field header)
(replace-field field #f header))
(define (insert-field field data header)
(if (bytes? header)
(let ([field (bytes-append field #": "data #"\r\n")])
(bytes-append field header))
;; otherwise field, data, & header should be strings:
(let ([field (format "~a: ~a\r\n" field data)])
(string-append field header))))
(define (append-headers a b)
(if (bytes? a)
(let ([alen (bytes-length a)])
(if (> alen 1)
(bytes-append (subbytes a 0 (- alen 2)) b)
(error 'append-headers "first argument is not a header: ~a" a)))
;; otherwise, a & b should be strings:
(let ([alen (string-length a)])
(if (> alen 1)
(string-append (substring a 0 (- alen 2)) b)
(error 'append-headers "first argument is not a header: ~a" a)))))
(define (extract-all-fields header)
(if (bytes? header)
(let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
(let loop ([start 0])
(let ([m (regexp-match-positions re header start)])
(if m
(let ([start (cdaddr m)]
[field-name (subbytes header (caaddr (cdr m))
(cdaddr (cdr m)))])
(let ([m2 (regexp-match-positions
#rx#"\r\n[^: \r\n\"]*:"
header
start)])
(if m2
(cons (cons field-name
(subbytes header start (caar m2)))
(loop (caar m2)))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(list
(cons field-name
(regexp-replace #rx#"\r\n\r\n$"
(subbytes header start (bytes-length header))
""))))))
;; malformed header:
null))))
;; otherwise, header should be a string:
(let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
(let loop ([start 0])
(let ([m (regexp-match-positions re header start)])
(if m
(let ([start (cdaddr m)]
[field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
(let ([m2 (regexp-match-positions
#rx"\r\n[^: \r\n\"]*:" header start)])
(if m2
(cons (cons field-name
(substring header start (caar m2)))
(loop (caar m2)))
;; Rest of header is this field, but strip trailing CRLFCRLF:
(list
(cons field-name
(regexp-replace #rx"\r\n\r\n$"
(substring header start (string-length header))
""))))))
;; malformed header:
null))))))
;; It's slightly less obvious how to generalize the functions that don't
;; accept a header as input; for lack of an obvious solution (and free time),
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
(define (standard-message-header from tos ccs bccs subject)
(let ([h (insert-field
"Subject" subject
(insert-field
"Date" (parameterize ([date-display-format 'rfc2822])
(date->string (seconds->date (current-seconds)) #t))
CRLF))])
;; NOTE: bccs don't go into the header; that's why they're "blind"
(let ([h (if (null? ccs)
h
(insert-field "CC" (assemble-address-field ccs) h))])
(let ([h (if (null? tos)
h
(insert-field "To" (assemble-address-field tos) h))])
(insert-field "From" from h)))))
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
(car l)
(apply string-append
(map (lambda (n) (format "~a~a" sep n))
(cdr l))))))
(define (data-lines->data datas)
(splice datas "\r\n\t"))
;; Extracting Addresses ;;
(define blank "[ \t\n\r\v]")
(define nonblank "[^ \t\n\r\v]")
(define re:all-blank (regexp (format "^~a*$" blank)))
(define re:quoted (regexp "\"[^\"]*\""))
(define re:parened (regexp "[(][^)]*[)]"))
(define re:comma (regexp ","))
(define re:comma-separated (regexp "([^,]*),(.*)"))
(define (extract-addresses s form)
(unless (memq form '(name address full all))
(raise-type-error 'extract-addresses
"form: 'name, 'address, 'full, or 'all"
form))
(if (or (not s) (regexp-match re:all-blank s))
null
(let loop ([prefix ""][s s])
;; Which comes first - a quote or a comma?
(let* ([mq1 (regexp-match-positions re:quoted s)]
[mq2 (regexp-match-positions re:parened s)]
[mq (if (and mq1 mq2)
(if (< (caar mq1) (caar mq2)) mq1 mq2)
(or mq1 mq2))]
[mc (regexp-match-positions re:comma s)])
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
;; Quote contains a comma
(loop (string-append
prefix
(substring s 0 (cdar mq)))
(substring s (cdar mq) (string-length s)))
;; Normal comma parsing:
(let ([m (regexp-match re:comma-separated s)])
(if m
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
[rest (extract-addresses (caddr m) form)])
(cons n rest))
(let ([n (extract-one-name (string-append prefix s) form)])
(list n)))))))))
(define (select-result form name addr full)
(case form
[(name) name]
[(address) addr]
[(full) full]
[(all) (list name addr full)]))
(define (one-result form s)
(select-result form s s s))
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
(define re:double-less (regexp "<.*<"))
(define re:double-greater (regexp ">.*>"))
(define re:bad-chars (regexp "[,\"()<>]"))
(define re:tail-blanks (regexp (format "~a+$" blank)))
(define re:head-blanks (regexp (format "^~a+" blank)))
(define (extract-one-name orig form)
(let loop ([s orig][form form])
(cond
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
[(regexp-match re:parened-name s)
=> (lambda (m)
(let ([name (caddr m)]
[all (loop (cadr m) 'all)])
(select-result
form
(if (string=? (car all) (cadr all)) name (car all))
(cadr all)
(format "~a (~a)" (caddr all) name))))]
[(regexp-match re:quoted-name s)
=> (lambda (m)
(let ([name (cadr m)]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(regexp-match re:simple-name s)
=> (lambda (m)
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(or (regexp-match "<" s) (regexp-match ">" s))
(one-result form (extract-angle-addr s orig))]
[else (one-result form (extract-simple-addr s orig))])))
(define (extract-angle-addr s orig)
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
(error 'extract-address "too many angle brackets: ~a" s)
(let ([m (regexp-match re:normal-name s)])
(if m
(extract-simple-addr (cadr m) orig)
(error 'extract-address "cannot parse address: ~a" orig)))))
(define (extract-simple-addr s orig)
(cond [(regexp-match re:bad-chars s)
(error 'extract-address "cannot parse address: ~a" orig)]
[else
;; final whitespace strip
(regexp-replace re:tail-blanks
(regexp-replace re:head-blanks s "")
"")]))
(define (assemble-address-field addresses)
(if (null? addresses)
""
(let loop ([addresses (cdr addresses)]
[s (car addresses)]
[len (string-length (car addresses))])
(if (null? addresses)
s
(let* ([addr (car addresses)]
[alen (string-length addr)])
(if (<= 72 (+ len alen))
(loop (cdr addresses)
(format "~a,~a~a~a~a"
s #\return #\linefeed
#\tab addr)
alen)
(loop (cdr addresses)
(format "~a, ~a" s addr)
(+ len alen 2))))))))
(provide head@)

556
collects/net/imap-unit.rkt
View File

@ -1,554 +1,8 @@
#lang racket/unit
#lang racket/base
(require racket/tcp "imap-sig.rkt" "private/rbtree.rkt")
(require racket/unit
"imap-sig.rkt" "imap.rkt")
(import)
(export imap^)
(define-unit-from-context imap@ imap^)
(define debug-via-stdio? #f)
(define eol (if debug-via-stdio? 'linefeed 'return-linefeed))
(define (tag-eq? a b)
(or (eq? a b)
(and (symbol? a)
(symbol? b)
(string-ci=? (symbol->string a) (symbol->string b)))))
(define field-names
(list (list 'uid (string->symbol "UID"))
(list 'header (string->symbol "RFC822.HEADER"))
(list 'body (string->symbol "RFC822.TEXT"))
(list 'size (string->symbol "RFC822.SIZE"))
(list 'flags (string->symbol "FLAGS"))))
(define flag-names
(list (list 'seen (string->symbol "\\Seen"))
(list 'answered (string->symbol "\\Answered"))
(list 'flagged (string->symbol "\\Flagged"))
(list 'deleted (string->symbol "\\Deleted"))
(list 'draft (string->symbol "\\Draft"))
(list 'recent (string->symbol "\\Recent"))
(list 'noinferiors (string->symbol "\\Noinferiors"))
(list 'noselect (string->symbol "\\Noselect"))
(list 'marked (string->symbol "\\Marked"))
(list 'unmarked (string->symbol "\\Unmarked"))
(list 'hasnochildren (string->symbol "\\HasNoChildren"))
(list 'haschildren (string->symbol "\\HasChildren"))))
(define (imap-flag->symbol f)
(or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a))) flag-names)
f))
(define (symbol->imap-flag s)
(cond [(assoc s flag-names) => cadr] [else s]))
(define (log-warning . args)
;; (apply printf args)
(void))
(define log log-warning)
(define make-msg-id
(let ([id 0])
(lambda ()
(begin0 (string->bytes/latin-1 (format "a~a " id))
(set! id (add1 id))))))
(define (starts-with? l n)
(and (>= (bytes-length l) (bytes-length n))
(bytes=? n (subbytes l 0 (bytes-length n)))))
(define (skip s n)
(subbytes s (if (number? n) n (bytes-length n))))
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
(car l)
(apply string-append
(map (lambda (n) (format "~a~a" sep n)) (cdr l))))))
(define (imap-read s r)
(let loop ([s s]
[r r]
[accum null]
[eol-k (lambda (accum) (reverse accum))]
[eop-k (lambda (s accum) (error 'imap-read "unxpected close parenthesis"))])
(cond
[(bytes=? #"" s)
(eol-k accum)]
[(char-whitespace? (integer->char (bytes-ref s 0)))
(loop (skip s 1) r accum eol-k eop-k)]
[else
(case (integer->char (bytes-ref s 0))
[(#\")
(let ([m (regexp-match #rx#"\"([^\"]*)\"(.*)" s)])
(if m
(loop (caddr m) r (cons (cadr m) accum) eol-k eop-k)
(error 'imap-read "didn't find end of quoted string in: ~a" s)))]
[(#\))
(eop-k (skip s 1) accum)]
[(#\() (letrec ([next-line
(lambda (accum)
(loop (read-bytes-line r eol) r
accum
next-line
finish-parens))]
[finish-parens
(lambda (s laccum)
(loop s r
(cons (reverse laccum) accum)
eol-k eop-k))])
(loop (skip s 1) r null next-line finish-parens))]
[(#\{) (let ([m (regexp-match #rx#"{([0-9]+)}(.*)" s)])
(cond
[(not m) (error 'imap-read "couldn't read {} number: ~a" s)]
[(not (bytes=? (caddr m) #"")) (error 'imap-read "{} not at end-of-line: ~a" s)]
[else
(loop #"" r
(cons (read-bytes (string->number
(bytes->string/latin-1 (cadr m)))
r)
accum)
eol-k eop-k)]))]
[else (let ([m (regexp-match #rx#"([^ (){}]+)(.*)" s)])
(if m
(loop (caddr m) r
(cons (let ([v (cadr m)])
(if (regexp-match #rx#"^[0-9]*$" v)
(string->number (bytes->string/latin-1 v))
(string->symbol (bytes->string/latin-1 v))))
accum)
eol-k eop-k)
(error 'imap-read "failure reading atom: ~a" s)))])])))
(define (get-response r id info-handler continuation-handler)
(let loop ()
(let ([l (read-bytes-line r eol)])
(log "raw-reply: ~s\n" l)
(cond [(eof-object? l)
(error 'imap-send "unexpected end-of-file from server")]
[(and id (starts-with? l id))
(let ([reply (imap-read (skip l id) r)])
(log "response: ~a\n" reply)
reply)]
[(starts-with? l #"* ")
(let ([info (imap-read (skip l 2) r)])
(log "info: ~s\n" info)
(info-handler info))
(when id (loop))]
[(starts-with? l #"+ ")
(if (null? continuation-handler)
(error 'imap-send "unexpected continuation request: ~a" l)
((car continuation-handler) loop (imap-read (skip l 2) r)))]
[else
(log-warning "warning: unexpected response for ~a: ~a\n" id l)
(when id (loop))]))))
;; A cmd is
;; * (box v) - send v literally via ~a
;; * string or bytes - protect as necessary
;; * (cons cmd null) - same as cmd
;; * (cons cmd cmd) - send cmd, space, cmd
(define (imap-send imap cmd info-handler . continuation-handler)
(let ([r (imap-r imap)]
[w (imap-w imap)]
[id (make-msg-id)])
(log "sending ~a~a\n" id cmd)
(fprintf w "~a" id)
(let loop ([cmd cmd])
(cond
[(box? cmd) (fprintf w "~a" (unbox cmd))]
[(string? cmd) (loop (string->bytes/utf-8 cmd))]
[(bytes? cmd)
(if (or (regexp-match #rx#"[ *\"\r\n]" cmd)
(equal? cmd #""))
(if (regexp-match #rx#"[\"\r\n]" cmd)
(begin
;; Have to send size, then continue if the
;; server consents
(fprintf w "{~a}\r\n" (bytes-length cmd))
(flush-output w)
(get-response r #f void (list (lambda (gloop data) (void))))
;; Continue by writing the data
(write-bytes cmd w))
(fprintf w "\"~a\"" cmd))
(fprintf w "~a" cmd))]
[(and (pair? cmd) (null? (cdr cmd))) (loop (car cmd))]
[(pair? cmd) (begin (loop (car cmd))
(fprintf w " ")
(loop (cdr cmd)))]))
(fprintf w "\r\n")
(flush-output w)
(get-response r id (wrap-info-handler imap info-handler)
continuation-handler)))
(define (check-ok reply)
(unless (and (pair? reply) (tag-eq? (car reply) 'OK))
(error 'check-ok "server error: ~s" reply)))
(define (ok-tag-eq? i t)
(and (tag-eq? (car i) 'OK)
((length i) . >= . 3)
(tag-eq? (cadr i) (string->symbol (format "[~a" t)))))
(define (ok-tag-val i)
(let ([v (caddr i)])
(and (symbol? v)
(let ([v (symbol->string v)])
(regexp-match #rx"[]]$" v)
(string->number (substring v 0 (sub1 (string-length v))))))))
(define (wrap-info-handler imap info-handler)
(lambda (i)
(when (and (list? i) ((length i) . >= . 2))
(cond
[(tag-eq? (cadr i) 'EXISTS)
(when (> (car i) (or (imap-exists imap) 0))
(set-imap-new?! imap #t))
(set-imap-exists! imap (car i))]
[(tag-eq? (cadr i) 'RECENT)
(set-imap-recent! imap (car i))]
[(tag-eq? (cadr i) 'EXPUNGE)
(let ([n (car i)])
(log "Recording expunge: ~s\n" n)
;; add it to the tree of expunges
(expunge-insert! (imap-expunges imap) n)
;; decrement exists count:
(set-imap-exists! imap (sub1 (imap-exists imap)))
;; adjust ids for any remembered fetches:
(fetch-shift! (imap-fetches imap) n))]
[(tag-eq? (cadr i) 'FETCH)
(fetch-insert!
(imap-fetches imap)
;; Convert result to assoc list:
(cons (car i)
(let ([new
(let loop ([l (caddr i)])
(if (null? l)
null
(cons (cons (car l) (cadr l))
(loop (cddr l)))))])
;; Keep anything not overridden:
(let ([old (cdr (or (fetch-find (imap-fetches imap) (car i))
'(0)))])
(let loop ([old old][new new])
(cond
[(null? old) new]
[(assq (caar old) new)
(loop (cdr old) new)]
[else (loop (cdr old) (cons (car old) new))]))))))]
[(ok-tag-eq? i 'UIDNEXT)
(set-imap-uidnext! imap (ok-tag-val i))]
[(ok-tag-eq? i 'UIDVALIDITY)
(set-imap-uidvalidity! imap (ok-tag-val i))]
[(ok-tag-eq? i 'UNSEEN)
(set-imap-uidvalidity! imap (ok-tag-val i))]))
(info-handler i)))
(define-struct imap (r w exists recent unseen uidnext uidvalidity
expunges fetches new?)
#:mutable)
(define (imap-connection? v) (imap? v))
(define imap-port-number
(make-parameter 143
(lambda (v)
(unless (and (number? v)
(exact? v)
(integer? v)
(<= 1 v 65535))
(raise-type-error 'imap-port-number
"exact integer in [1,65535]"
v))
v)))
(define (imap-connect* r w username password inbox)
(with-handlers ([void
(lambda (x)
(close-input-port r)
(close-output-port w)
(raise x))])
(let ([imap (make-imap r w #f #f #f #f #f
(new-tree) (new-tree) #f)])
(check-ok (imap-send imap "NOOP" void))
(let ([reply (imap-send imap (list "LOGIN" username password) void)])
(if (and (pair? reply) (tag-eq? 'NO (car reply)))
(error 'imap-connect
"username or password rejected by server: ~s" reply)
(check-ok reply)))
(let-values ([(init-count init-recent) (imap-reselect imap inbox)])
(values imap init-count init-recent)))))
(define (imap-connect server username password inbox)
;; => imap count-k recent-k
(let-values ([(r w)
(if debug-via-stdio?
(begin
(printf "stdin == ~a\n" server)
(values (current-input-port) (current-output-port)))
(tcp-connect server (imap-port-number)))])
(imap-connect* r w username password inbox)))
(define (imap-reselect imap inbox)
(imap-selectish-command imap (list "SELECT" inbox) #t))
(define (imap-examine imap inbox)
(imap-selectish-command imap (list "EXAMINE" inbox) #t))
;; Used to return (values #f #f) if no change since last check?
(define (imap-noop imap)
(imap-selectish-command imap "NOOP" #f))
(define (imap-selectish-command imap cmd reset?)
(let ([init-count #f]
[init-recent #f])
(check-ok (imap-send imap cmd void))
(when reset?
(set-imap-expunges! imap (new-tree))
(set-imap-fetches! imap (new-tree))
(set-imap-new?! imap #f))
(values (imap-exists imap) (imap-recent imap))))
(define (imap-status imap inbox flags)
(unless (and (list? flags)
(andmap (lambda (s)
(memq s '(messages recent uidnext uidvalidity unseen)))
flags))
(raise-type-error 'imap-status "list of status flag symbols" flags))
(let ([results null])
(check-ok (imap-send imap (list "STATUS" inbox (box (format "~a" flags)))
(lambda (i)
(when (and (list? i) (= 3 (length i))
(tag-eq? (car i) 'STATUS))
(set! results (caddr i))))))
(map (lambda (f)
(let loop ([l results])
(cond
[(or (null? l) (null? (cdr l))) #f]
[(tag-eq? f (car l)) (cadr l)]
[else (loop (cdr l))])))
flags)))
(define (imap-poll imap)
(when (and ;; Check for async messages from the server
(char-ready? (imap-r imap))
;; It has better start with "*"...
(= (peek-byte (imap-r imap)) (char->integer #\*)))
;; May set fields in `imap':
(get-response (imap-r imap) #f (wrap-info-handler imap void) null)
(void)))
(define (imap-get-updates imap)
(no-expunges 'imap-updates imap)
(let ([l (fetch-tree->list (imap-fetches imap))])
(set-imap-fetches! imap (new-tree))
l))
(define (imap-pending-updates? imap)
(not (tree-empty? (imap-fetches imap))))
(define (imap-get-expunges imap)
(let ([l (expunge-tree->list (imap-expunges imap))])
(set-imap-expunges! imap (new-tree))
l))
(define (imap-pending-expunges? imap)
(not (tree-empty? (imap-expunges imap))))
(define (imap-reset-new! imap)
(set-imap-new?! imap #f))
(define (imap-messages imap)
(imap-exists imap))
(define (imap-disconnect imap)
(let ([r (imap-r imap)]
[w (imap-w imap)])
(check-ok (imap-send imap "LOGOUT" void))
(close-input-port r)
(close-output-port w)))
(define (imap-force-disconnect imap)
(let ([r (imap-r imap)]
[w (imap-w imap)])
(close-input-port r)
(close-output-port w)))
(define (no-expunges who imap)
(unless (tree-empty? (imap-expunges imap))
(raise-mismatch-error who "session has pending expunge reports: " imap)))
(define (msg-set msgs)
(apply
string-append
(let loop ([prev #f][msgs msgs])
(cond
[(null? msgs) null]
[(and prev
(pair? (cdr msgs))
(= (add1 prev) (car msgs)))
(loop (car msgs) (cdr msgs))]
[prev (cons (format ":~a," prev)
(loop #f msgs))]
[(null? (cdr msgs)) (list (format "~a" (car msgs)))]
[(= (add1 (car msgs)) (cadr msgs))
(cons (format "~a" (car msgs))
(loop (car msgs) (cdr msgs)))]
[else (cons (format "~a," (car msgs))
(loop #f (cdr msgs)))]))))
(define (imap-get-messages imap msgs field-list)
(no-expunges 'imap-get-messages imap)
(when (or (not (list? msgs))
(not (andmap integer? msgs)))
(raise-type-error 'imap-get-messages "non-empty message list" msgs))
(when (or (null? field-list)
(not (list? field-list))
(not (andmap (lambda (f) (assoc f field-names)) field-list)))
(raise-type-error 'imap-get-messages "non-empty field list" field-list))
(if (null? msgs)
null
(begin
;; FETCH request adds info to `(imap-fectches imap)':
(imap-send imap
(list "FETCH"
(box (msg-set msgs))
(box
(format "(~a)"
(splice (map (lambda (f)
(cadr (assoc f field-names)))
field-list)
" "))))
void)
;; Sort out the collected info:
(let ([flds (map (lambda (f) (cadr (assoc f field-names)))
field-list)])
(begin0
;; For each msg, try to get each field value:
(map
(lambda (msg)
(let ([m (or (fetch-find (imap-fetches imap) msg)
(error 'imap-get-messages "no result for message ~a" msg))])
(let loop ([flds flds][m (cdr m)])
(cond
[(null? flds)
(if (null? m)
(fetch-delete! (imap-fetches imap) msg)
(fetch-insert! (imap-fetches imap) (cons msg m)))
null]
[else
(let ([a (assoc (car flds) m)])
(cons (and a (cdr a))
(loop (cdr flds) (if a (remq a m) m))))]))))
msgs))))))
(define (imap-store imap mode msgs flags)
(no-expunges 'imap-store imap)
(check-ok
(imap-send imap
(list "STORE"
(box (msg-set msgs))
(case mode
[(+) "+FLAGS.SILENT"]
[(-) "-FLAGS.SILENT"]
[(!) "FLAGS.SILENT"]
[else (raise-type-error 'imap-store
"mode: '!, '+, or '-" mode)])
(box (format "~a" flags)))
void)))
(define (imap-copy imap msgs dest-mailbox)
(no-expunges 'imap-copy imap)
(check-ok
(imap-send imap (list "COPY" (box (msg-set msgs)) dest-mailbox) void)))
(define (imap-append imap dest-mailbox msg)
(no-expunges 'imap-append imap)
(let ([msg (if (bytes? msg) msg (string->bytes/utf-8 msg))])
(check-ok
(imap-send imap (list "APPEND"
dest-mailbox
(box "(\\Seen)")
(box (format "{~a}" (bytes-length msg))))
void
(lambda (loop contin)
(fprintf (imap-w imap) "~a\r\n" msg)
(loop))))))
(define (imap-expunge imap)
(check-ok (imap-send imap "EXPUNGE" void)))
(define (imap-mailbox-exists? imap mailbox)
(let ([exists? #f])
(check-ok (imap-send imap
(list "LIST" "" mailbox)
(lambda (i)
(when (and (pair? i) (tag-eq? (car i) 'LIST))
(set! exists? #t)))))
exists?))
(define (imap-create-mailbox imap mailbox)
(check-ok (imap-send imap (list "CREATE" mailbox) void)))
(define (imap-get-hierarchy-delimiter imap)
(let ([result #f])
(check-ok
(imap-send imap (list "LIST" "" "")
(lambda (i)
(when (and (pair? i) (tag-eq? (car i) 'LIST))
(set! result (caddr i))))))
result))
(define imap-list-child-mailboxes
(case-lambda
[(imap mailbox)
(imap-list-child-mailboxes imap mailbox #f)]
[(imap mailbox raw-delimiter)
(let* ([delimiter (or raw-delimiter (imap-get-hierarchy-delimiter imap))]
[mailbox-name (and mailbox (bytes-append mailbox delimiter))]
[pattern (if mailbox
(bytes-append mailbox-name #"%")
#"%")])
(map (lambda (p)
(list (car p)
(cond
[(symbol? (cadr p))
(string->bytes/utf-8 (symbol->string (cadr p)))]
[(string? (cadr p))
(string->bytes/utf-8 (symbol->string (cadr p)))]
[(bytes? (cadr p))
(cadr p)])))
(imap-list-mailboxes imap pattern mailbox-name)))]))
(define (imap-mailbox-flags imap mailbox)
(let ([r (imap-list-mailboxes imap mailbox #f)])
(if (= (length r) 1)
(caar r)
(error 'imap-mailbox-flags "could not get flags for ~s (~a)"
mailbox
(if (null? r) "no matches" "multiple matches")))))
(define (imap-list-mailboxes imap pattern except)
(let* ([sub-folders null])
(check-ok
(imap-send imap (list "LIST" "" pattern)
(lambda (x)
(when (and (pair? x)
(tag-eq? (car x) 'LIST))
(let* ([flags (cadr x)]
[name (cadddr x)]
[bytes-name (if (symbol? name)
(string->bytes/utf-8 (symbol->string name))
name)])
(unless (and except
(bytes=? bytes-name except))
(set! sub-folders
(cons (list flags name) sub-folders))))))))
(reverse sub-folders)))
(provide imap@)

736
collects/net/mime-unit.rkt
View File

@ -1,734 +1,8 @@
;;;
;;; <mime-unit.rkt> ---- MIME support
;;;
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Wish Computing.
;;;
;;; This file is part of mime
#lang racket/base
;;; mime-plt is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.
(require racket/unit
"mime-sig.rkt" "mime.rkt")
;;; mime-plt is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
(define-unit-from-context mime@ mime^)
;;; You should have received a copy of the GNU General Public License
;;; along with mime-plt; see the file COPYING. If not, write to the
;;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;; Boston, MA 02110-1301 USA.
;;; Author: Francisco Solsona <solsona@acm.org>
;;
;;
;; Commentary: MIME support for PLT Scheme: an implementation of
;; rfc2045, rfc2046, rfc2047, rfc2048, and rfc2049.
#lang racket/unit
(require "mime-sig.rkt" "qp-sig.rkt" "base64-sig.rkt" "head-sig.rkt"
"mime-util.rkt"
racket/port)
(import base64^ qp^ head^)
(export mime^)
;; Constants:
(define discrete-alist
'(("text" . text)
("image" . image)
("audio" . audio)
("video" . video)
("application" . application)))
(define disposition-alist
'(("inline" . inline)
("attachment" . attachment)
("file" . attachment) ;; This is used (don't know why) by
;; multipart/form-data
("messagetext" . inline)
("form-data" . form-data)))
(define composite-alist
'(("message" . message)
("multipart" . multipart)))
(define mechanism-alist
'(("7bit" . 7bit)
("8bit" . 8bit)
("binary" . binary)
("quoted-printable" . quoted-printable)
("base64" . base64)))
(define ietf-extensions '())
(define iana-extensions
'(;; text
("plain" . plain)
("html" . html)
("enriched" . enriched) ; added 5/2005 - probably not iana
("richtext" . richtext)
("tab-separated-values" . tab-separated-values)
;; Multipart
("mixed" . mixed)
("alternative" . alternative)
("digest" . digest)
("parallel" . parallel)
("appledouble" . appledouble)
("header-set" . header-set)
("form-data" . form-data)
;; Message
("rfc822" . rfc822)
("partial" . partial)
("external-body" . external-body)
("news" . news)
;; Application
("octet-stream" . octet-stream)
("postscript" . postscript)
("oda" . oda)
("atomicmail" . atomicmail)
("andrew-inset" . andrew-inset)
("slate" . slate)
("wita" . wita)
("dec-dx" . dec-dx)
("dca-rf" . dca-rf)
("activemessage" . activemessage)
("rtf" . rtf)
("applefile" . applefile)
("mac-binhex40" . mac-binhex40)
("news-message-id" . news-message-id)
("news-transmissio" . news-transmissio)
("wordperfect5.1" . wordperfect5.1)
("pdf" . pdf)
("zip" . zip)
("macwritei" . macwritei)
;; "image"
("jpeg" . jpeg)
("gif" . gif)
("ief" . ief)
("tiff" . tiff)
;; "audio"
("basic" . basic)
;; "video" .
("mpeg" . mpeg)
("quicktime" . quicktime)))
;; Basic structures
(define-struct message (version entity fields)
#:mutable)
(define-struct entity
(type subtype charset encoding disposition params id description other
fields parts body)
#:mutable)
(define-struct disposition
(type filename creation modification read size params)
#:mutable)
;; Exceptions
(define-struct mime-error ())
(define-struct (unexpected-termination mime-error) (msg))
(define-struct (missing-multipart-boundary-parameter mime-error) ())
(define-struct (malformed-multipart-entity mime-error) (msg))
(define-struct (empty-mechanism mime-error) ())
(define-struct (empty-type mime-error) ())
(define-struct (empty-subtype mime-error) ())
(define-struct (empty-disposition-type mime-error) ())
;; *************************************
;; Practical stuff, aka MIME in action:
;; *************************************
(define CRLF (format "~a~a" #\return #\newline))
(define CRLF-binary "=0D=0A") ;; quoted printable representation
;; get-headers : input-port -> string
;; returns the header part of a message/part conforming to rfc822, and
;; rfc2045.
(define (get-headers in)
(let loop ([headers ""] [ln (read-line in 'any)])
(cond [(eof-object? ln)
;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
(warning "premature eof while parsing headers")
headers]
[(string=? ln "") headers]
[else
;; Quoting rfc822:
;; " Headers occur before the message body and are
;; terminated by a null line (i.e., two contiguous
;; CRLFs)."
;; That is: Two empty lines. But most MUAs seem to count
;; the CRLF ending the last field (header) as the first
;; CRLF of the null line.
(loop (string-append headers ln CRLF)
(read-line in 'any))])))
(define (make-default-disposition)
(make-disposition
'inline ;; type
"" ;; filename
#f ;; creation
#f ;; modification
#f ;; read
#f ;; size
null ;; params
))
(define (make-default-entity)
(make-entity
'text ;; type
'plain ;; subtype
'us-ascii ;; charset
'7bit ;; encoding
(make-default-disposition) ;; disposition
null ;; params
"" ;; id
"" ;; description
null ;; other MIME fields (MIME-extension-fields)
null ;; fields
null ;; parts
null ;; body
))
(define (make-default-message)
(make-message 1.0 (make-default-entity) null))
(define (mime-decode entity input)
(set-entity-body!
entity
(case (entity-encoding entity)
[(quoted-printable)
(lambda (output)
(qp-decode-stream input output))]
[(base64)
(lambda (output)
(base64-decode-stream input output))]
[else ;; 7bit, 8bit, binary
(lambda (output)
(copy-port input output))])))
(define (mime-analyze input [part #f])
(let* ([iport (if (bytes? input)
(open-input-bytes input)
input)]
[headers (get-headers iport)]
[msg (if part
(MIME-part-headers headers)
(MIME-message-headers headers))]
[entity (message-entity msg)])
;; OK we have in msg a MIME-message structure, lets see what we have:
(case (entity-type entity)
[(text image audio video application)
;; decode part, and save port and thunk
(mime-decode entity iport)]
[(message multipart)
(let ([boundary (entity-boundary entity)])
(when (not boundary)
(when (eq? 'multipart (entity-type entity))
(raise (make-missing-multipart-boundary-parameter))))
(set-entity-parts! entity
(map (lambda (part)
(mime-analyze part #t))
(if boundary
(multipart-body iport boundary)
(list iport)))))]
[else
;; Unrecognized type, you're on your own! (sorry)
(mime-decode entity iport)])
;; return mime structure
msg))
(define (entity-boundary entity)
(let* ([params (entity-params entity)]
[ans (assoc "boundary" params)])
(and ans (cdr ans))))
;; *************************************************
;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
;; *************************************************
;;multipart-body := [preamble CRLF]
;; dash-boundary transport-padding CRLF
;; body-part *encapsulation
;; close-delimiter transport-padding
;; [CRLF epilogue]
;; Returns a list of input ports, each one containing the correspongind part.
(define (multipart-body input boundary)
(let* ([make-re (lambda (prefix)
(regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
[re (make-re "\r\n")])
(letrec ([eat-part (lambda ()
(let-values ([(pin pout) (make-pipe)])
(let ([m (regexp-match re input 0 #f pout)])
(cond
[(not m)
(close-output-port pout)
(values pin ;; part
#f ;; close-delimiter?
#t ;; eof reached?
)]
[(cadr m)
(close-output-port pout)
(values pin #t #f)]
[else
(close-output-port pout)
(values pin #f #f)]))))])
;; pre-amble is allowed to be completely empty:
(if (regexp-match-peek (make-re "^") input)
;; No \r\f before first separator:
(read-line input)
;; non-empty preamble:
(eat-part))
(let loop ()
(let-values ([(part close? eof?) (eat-part)])
(cond [close? (list part)]
[eof? (list part)]
[else (cons part (loop))]))))))
;; MIME-message-headers := entity-headers
;; fields
;; version CRLF
;; ; The ordering of the header
;; ; fields implied by this BNF
;; ; definition should be ignored.
(define (MIME-message-headers headers)
(let ([message (make-default-message)])
(entity-headers headers message #t)
message))
;; MIME-part-headers := entity-headers
;; [ fields ]
;; ; Any field not beginning with
;; ; "content-" can have no defined
;; ; meaning and may be ignored.
;; ; The ordering of the header
;; ; fields implied by this BNF
;; ; definition should be ignored.
(define (MIME-part-headers headers)
(let ([message (make-default-message)])
(entity-headers headers message #f)
message))
;; entity-headers := [ content CRLF ]
;; [ encoding CRLF ]
;; [ id CRLF ]
;; [ description CRLF ]
;; *( MIME-extension-field CRLF )
(define (entity-headers headers message version?)
(let ([entity (message-entity message)])
(let-values ([(mime non-mime) (get-fields headers)])
(let loop ([fields mime])
(unless (null? fields)
;; Process MIME field
(let ([trimmed-h (trim-comments (car fields))])
(or (and version? (version trimmed-h message))
(content trimmed-h entity)
(encoding trimmed-h entity)
(dispositione trimmed-h entity)
(id trimmed-h entity)
(description trimmed-h entity)
(MIME-extension-field trimmed-h entity))
;; keep going
(loop (cdr fields)))))
;; NON-mime headers (or semantically incorrect). In order to make
;; this implementation of rfc2045 robuts, we will save the header in
;; the fields field of the message struct:
(set-message-fields! message non-mime)
;; Return message
message)))
(define (get-fields headers)
(let ([mime null] [non-mime null])
(letrec ([store-field
(lambda (f)
(unless (string=? f "")
(if (mime-header? f)
(set! mime (append mime (list (trim-spaces f))))
(set! non-mime (append non-mime (list (trim-spaces f)))))))])
(let ([fields (extract-all-fields headers)])
(for-each (lambda (p)
(store-field (format "~a: ~a" (car p) (cdr p))))
fields))
(values mime non-mime))))
(define re:content #rx"^(?i:content-)")
(define re:mime #rx"^(?i:mime-version):")
(define (mime-header? h)
(or (regexp-match? re:content h)
(regexp-match? re:mime h)))
;;; Headers
;;; Content-type follows this BNF syntax:
;; content := "Content-Type" ":" type "/" subtype
;; *(";" parameter)
;; ; Matching of media type and subtype
;; ; is ALWAYS case-insensitive.
(define re:content-type #rx"^(?i:content-type):([^/]+)/([^/]+)$")
(define (content header entity)
(let* ([params (string-tokenizer #\; header)]
[one re:content-type]
[h (trim-all-spaces (car params))]
[target (regexp-match one h)]
[old-param (entity-params entity)])
(and target
(set-entity-type! entity
(type (regexp-replace one h "\\1"))) ;; type
(set-entity-subtype! entity
(subtype (regexp-replace one h "\\2"))) ;; subtype
(set-entity-params!
entity
(append old-param
(let loop ([p (cdr params)] ;; parameters
[ans null])
(cond [(null? p) ans]
[else
(let ([par-pair (parameter (trim-all-spaces (car p)))])
(cond [par-pair
(when (string=? (car par-pair) "charset")
(set-entity-charset! entity (cdr par-pair)))
(loop (cdr p) (append ans (list par-pair)))]
[else
(warning "Invalid parameter for Content-Type: `~a'" (car p))
;; go on...
(loop (cdr p) ans)]))])))))))
;; From rfc2183 Content-Disposition
;; disposition := "Content-Disposition" ":"
;; disposition-type
;; *(";" disposition-parm)
(define re:content-disposition #rx"^(?i:content-disposition):(.+)$")
(define (dispositione header entity)
(let* ([params (string-tokenizer #\; header)]
[reg re:content-disposition]
[h (trim-all-spaces (car params))]
[target (regexp-match reg h)]
[disp-struct (entity-disposition entity)])
(and target
(set-disposition-type!
disp-struct
(disp-type (regexp-replace reg h "\\1")))
(disp-params (cdr params) disp-struct))))
;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
(define re:mime-version #rx"^(?i:MIME-Version):([0-9]+)\\.([0-9]+)$")
(define (version header message)
(let* ([reg re:mime-version]
[h (trim-all-spaces header)]
[target (regexp-match reg h)])
(and target
(set-message-version!
message
(string->number (regexp-replace reg h "\\1.\\2"))))))
;; description := "Content-Description" ":" *text
(define re:content-description #rx"^(?i:content-description):[ \t\r\n]*(.*)$")
(define (description header entity)
(let* ([reg re:content-description]
[target (regexp-match reg header)])
(and target
(set-entity-description!
entity
(trim-spaces (regexp-replace reg header "\\1"))))))
;; encoding := "Content-Transfer-Encoding" ":" mechanism
(define re:content-transfer-encoding #rx"^(?i:content-transfer-encoding):(.+)$")
(define (encoding header entity)
(let* ([reg re:content-transfer-encoding]
[h (trim-all-spaces header)]
[target (regexp-match reg h)])
(and target
(set-entity-encoding!
entity
(mechanism (regexp-replace reg h "\\1"))))))
;; id := "Content-ID" ":" msg-id
(define re:content-id #rx"^(?i:content-id):(.+)$")
(define (id header entity)
(let* ([reg re:content-id]
[h (trim-all-spaces header)]
[target (regexp-match reg h)])
(and target
(set-entity-id!
entity
(msg-id (regexp-replace reg h "\\1"))))))
;; From rfc822:
;; msg-id = "<" addr-spec ">" ; Unique message id
;; addr-spec = local-part "@" domain ; global address
;; local-part = word *("." word) ; uninterpreted
;; ; case-preserved
;; domain = sub-domain *("." sub-domain)
;; sub-domain = domain-ref / domain-literal
;; domain-literal = "[" *(dtext / quoted-pair) "]"
;; domain-ref = atom ; symbolic reference
(define (msg-id str)
(let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
[ans (regexp-match r str)])
(if ans
str
(begin (warning "Invalid msg-id: ~a" str) str))))
;; mechanism := "7bit" / "8bit" / "binary" /
;; "quoted-printable" / "base64" /
;; ietf-token / x-token
(define (mechanism mech)
(if (not mech)
(raise (make-empty-mechanism))
(let ([val (assoc (lowercase mech) mechanism-alist)])
(or (and val (cdr val))
(ietf-token mech)
(x-token mech)))))
;; MIME-extension-field := <Any RFC 822 header field which
;; begins with the string
;; "Content-">
;;
(define (MIME-extension-field header entity)
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
[target (regexp-match reg header)])
(and target
(set-entity-other!
entity
(append (entity-other entity)
(list (cons (regexp-replace reg header "\\1")
(trim-spaces (regexp-replace reg header "\\2")))))))))
;; type := discrete-type / composite-type
(define (type value)
(if (not value)
(raise (make-empty-type))
(or (discrete-type value)
(composite-type value))))
;; disposition-type := "inline" / "attachment" / extension-token
(define (disp-type value)
(if (not value)
(raise (make-empty-disposition-type))
(let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
(if val (cdr val) (extension-token value)))))
;; discrete-type := "text" / "image" / "audio" / "video" /
;; "application" / extension-token
(define (discrete-type value)
(let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
(if val (cdr val) (extension-token value))))
;; composite-type := "message" / "multipart" / extension-token
(define (composite-type value)
(let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
(if val (cdr val) (extension-token value))))
;; extension-token := ietf-token / x-token
(define (extension-token value)
(or (ietf-token value)
(x-token value)))
;; ietf-token := <An extension token defined by a
;; standards-track RFC and registered
;; with IANA.>
(define (ietf-token value)
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
(and ans (cdr ans))))
;; Directly from RFC 1700:
;; Type Subtype Description Reference
;; ---- ------- ----------- ---------
;; text plain [RFC1521,NSB]
;; richtext [RFC1521,NSB]
;; tab-separated-values [Paul Lindner]
;;
;; multipart mixed [RFC1521,NSB]
;; alternative [RFC1521,NSB]
;; digest [RFC1521,NSB]
;; parallel [RFC1521,NSB]
;; appledouble [MacMime,Patrik Faltstrom]
;; header-set [Dave Crocker]
;;
;; message rfc822 [RFC1521,NSB]
;; partial [RFC1521,NSB]
;; external-body [RFC1521,NSB]
;; news [RFC 1036, Henry Spencer]
;;
;; application octet-stream [RFC1521,NSB]
;; postscript [RFC1521,NSB]
;; oda [RFC1521,NSB]
;; atomicmail [atomicmail,NSB]
;; andrew-inset [andrew-inset,NSB]
;; slate [slate,terry crowley]
;; wita [Wang Info Transfer,Larry Campbell]
;; dec-dx [Digital Doc Trans, Larry Campbell]
;; dca-rft [IBM Doc Content Arch, Larry Campbell]
;; activemessage [Ehud Shapiro]
;; rtf [Paul Lindner]
;; applefile [MacMime,Patrik Faltstrom]
;; mac-binhex40 [MacMime,Patrik Faltstrom]
;; news-message-id [RFC1036, Henry Spencer]
;; news-transmission [RFC1036, Henry Spencer]
;; wordperfect5.1 [Paul Lindner]
;; pdf [Paul Lindner]
;; zip [Paul Lindner]
;; macwriteii [Paul Lindner]
;; msword [Paul Lindner]
;; remote-printing [RFC1486,MTR]
;;
;; image jpeg [RFC1521,NSB]
;; gif [RFC1521,NSB]
;; ief Image Exchange Format [RFC1314]
;; tiff Tag Image File Format [MTR]
;;
;; audio basic [RFC1521,NSB]
;;
;; video mpeg [RFC1521,NSB]
;; quicktime [Paul Lindner]
;; x-token := <The two characters "X-" or "x-" followed, with
;; no intervening white space, by any token>
(define (x-token value)
(let* ([r #rx"^[xX]-(.*)"]
[h (trim-spaces value)]
[ans (regexp-match r h)])
(and ans
(token (regexp-replace r h "\\1"))
h)))
;; subtype := extension-token / iana-token
(define (subtype value)
(if (not value)
(raise (make-empty-subtype))
(or (extension-token value)
(iana-token value))))
;; iana-token := <A publicly-defined extension token. Tokens
;; of this form must be registered with IANA
;; as specified in RFC 2048.>
(define (iana-token value)
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
(and ans (cdr ans))))
;; parameter := attribute "=" value
(define re:parameter (regexp "([^=]+)=(.+)"))
(define (parameter par)
(let* ([r re:parameter]
[att (attribute (regexp-replace r par "\\1"))]
[val (value (regexp-replace r par "\\2"))])
(if (regexp-match r par)
(cons (if att (lowercase att) "???") val)
(cons "???" par))))
;; value := token / quoted-string
(define (value val)
(or (token val)
(quoted-string val)
val))
;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
;; or tspecials>
;; tspecials := "(" / ")" / "<" / ">" / "@" /
;; "," / ";" / ":" / "\" / <">
;; "/" / "[" / "]" / "?" / "="
;; ; Must be in quoted-string,
;; ; to use within parameter values
(define (token value)
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
[ans (regexp-match tspecials value)])
(and ans
(string=? value (car ans))
(car ans))))
;; attribute := token
;; ; Matching of attributes
;; ; is ALWAYS case-insensitive.
(define attribute token)
(define re:quotes (regexp "\"(.+)\""))
(define (quoted-string str)
(let* ([quotes re:quotes]
[ans (regexp-match quotes str)])
(and ans (regexp-replace quotes str "\\1"))))
;; disposition-parm := filename-parm
;; / creation-date-parm
;; / modification-date-parm
;; / read-date-parm
;; / size-parm
;; / parameter
;;
;; filename-parm := "filename" "=" value
;;
;; creation-date-parm := "creation-date" "=" quoted-date-time
;;
;; modification-date-parm := "modification-date" "=" quoted-date-time
;;
;; read-date-parm := "read-date" "=" quoted-date-time
;;
;; size-parm := "size" "=" 1*DIGIT
(define (disp-params lst disp)
(let loop ([lst lst])
(unless (null? lst)
(let* ([p (parameter (trim-all-spaces (car lst)))]
[parm (car p)]
[value (cdr p)])
(cond [(string=? parm "filename")
(set-disposition-filename! disp value)]
[(string=? parm "creation-date")
(set-disposition-creation!
disp
(disp-quoted-data-time value))]
[(string=? parm "modification-date")
(set-disposition-modification!
disp
(disp-quoted-data-time value))]
[(string=? parm "read-date")
(set-disposition-read!
disp
(disp-quoted-data-time value))]
[(string=? parm "size")
(set-disposition-size!
disp
(string->number value))]
[else
(set-disposition-params!
disp
(append (disposition-params disp) (list p)))])
(loop (cdr lst))))))
;; date-time = [ day "," ] date time ; dd mm yy
;; ; hh:mm:ss zzz
;;
;; day = "Mon" / "Tue" / "Wed" / "Thu"
;; / "Fri" / "Sat" / "Sun"
;;
;; date = 1*2DIGIT month 2DIGIT ; day month year
;; ; e.g. 20 Jun 82
;;
;; month = "Jan" / "Feb" / "Mar" / "Apr"
;; / "May" / "Jun" / "Jul" / "Aug"
;; / "Sep" / "Oct" / "Nov" / "Dec"
;;
;; time = hour zone ; ANSI and Military
;;
;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT]
;; ; 00:00:00 - 23:59:59
;;
;; zone = "UT" / "GMT" ; Universal Time
;; ; North American : UT
;; / "EST" / "EDT" ; Eastern: - 5/ - 4
;; / "CST" / "CDT" ; Central: - 6/ - 5
;; / "MST" / "MDT" ; Mountain: - 7/ - 6
;; / "PST" / "PDT" ; Pacific: - 8/ - 7
;; / 1ALPHA ; Military: Z = UT;
;; ; A:-1; (J not used)
;; ; M:-12; N:+1; Y:+12
;; / ( ("+" / "-") 4DIGIT ) ; Local differential
;; ; hours+min. (HHMM)
(define date-time
(lambda (str)
;; Fix Me: I have to return a date structure, or time in seconds.
str))
;; quoted-date-time := quoted-string
;; ; contents MUST be an RFC 822 `date-time'
;; ; numeric timezones (+HHMM or -HHMM) MUST be used
(define disp-quoted-data-time date-time)
(provide mime@)

312
collects/net/nntp-unit.rkt
View File

@ -1,310 +1,8 @@
#lang racket/unit
#lang racket/base
(require racket/tcp "nntp-sig.rkt")
(require racket/unit
"nntp-sig.rkt" "nntp.rkt")
(import)
(export nntp^)
(define-unit-from-context nntp@ nntp^)
;; sender : oport
;; receiver : iport
;; server : string
;; port : number
(define-struct communicator (sender receiver server port))
;; code : number
;; text : string
;; line : string
;; communicator : communicator
;; group : string
;; article : number
(define-struct (nntp exn) ())
(define-struct (unexpected-response nntp) (code text))
(define-struct (bad-status-line nntp) (line))
(define-struct (premature-close nntp) (communicator))
(define-struct (bad-newsgroup-line nntp) (line))
(define-struct (non-existent-group nntp) (group))
(define-struct (article-not-in-group nntp) (article))
(define-struct (no-group-selected nntp) ())
(define-struct (article-not-found nntp) (article))
(define-struct (authentication-rejected nntp) ())
;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> ()
;; - throws an exception
(define (signal-error constructor format-string . args)
(lambda exn-args
(raise (apply constructor
(apply format format-string args)
(current-continuation-marks)
exn-args))))
;; default-nntpd-port-number :
;; number
(define default-nntpd-port-number 119)
;; connect-to-server*:
;; input-port output-port -> communicator
(define connect-to-server*
(case-lambda
[(receiver sender)
(connect-to-server* receiver sender "unspecified" "unspecified")]
[(receiver sender server-name port-number)
(file-stream-buffer-mode sender 'line)
(let ([communicator (make-communicator sender receiver server-name
port-number)])
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
[(200 201) communicator]
[else ((signal-error make-unexpected-response
"unexpected connection response: ~s ~s"
code response)
code response)])))]))
;; connect-to-server :
;; string [x number] -> commnicator
(define connect-to-server
(lambda (server-name (port-number default-nntpd-port-number))
(let-values ([(receiver sender)
(tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number))))
;; close-communicator :
;; communicator -> ()
(define (close-communicator communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator)))
;; disconnect-from-server :
;; communicator -> ()
(define (disconnect-from-server communicator)
(send-to-server communicator "QUIT")
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
[(205)
(close-communicator communicator)]
[else
((signal-error make-unexpected-response
"unexpected dis-connect response: ~s ~s"
code response)
code response)])))
;; authenticate-user :
;; communicator x user-name x password -> ()
;; the password is not used if the server does not ask for it.
(define (authenticate-user communicator user password)
(define (reject code response)
((signal-error make-authentication-rejected
"authentication rejected (~s ~s)"
code response)))
(define (unexpected code response)
((signal-error make-unexpected-response
"unexpected response for authentication: ~s ~s"
code response)
code response))
(send-to-server communicator "AUTHINFO USER ~a" user)
(let-values ([(code response) (get-single-line-response communicator)])
(case code
[(281) (void)] ; server doesn't ask for a password
[(381)
(send-to-server communicator "AUTHINFO PASS ~a" password)
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
[(281) (void)] ; done
[(502) (reject code response)]
[else (unexpected code response)]))]
[(502) (reject code response)]
[else (reject code response)
(unexpected code response)])))
;; send-to-server :
;; communicator x format-string x list (values) -> ()
(define (send-to-server communicator message-template . rest)
(let ([sender (communicator-sender communicator)])
(apply fprintf sender
(string-append message-template "\r\n")
rest)
(flush-output sender)))
;; parse-status-line :
;; string -> number x string
(define (parse-status-line line)
(if (eof-object? line)
((signal-error make-bad-status-line "eof instead of a status line")
line)
(let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
((signal-error make-bad-status-line
"malformed status line: ~s" line)
line)))])
(values (string->number (car match))
(cadr match)))))
;; get-one-line-from-server :
;; iport -> string
(define (get-one-line-from-server server->client-port)
(read-line server->client-port 'return-linefeed))
;; get-single-line-response :
;; communicator -> number x string
(define (get-single-line-response communicator)
(let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)])
(parse-status-line status-line)))
;; get-rest-of-multi-line-response :
;; communicator -> list (string)
(define (get-rest-of-multi-line-response communicator)
(let ([receiver (communicator-receiver communicator)])
(let loop ([r '()])
(let ([l (get-one-line-from-server receiver)])
(cond
[(eof-object? l)
((signal-error make-premature-close
"port prematurely closed during multi-line response")
communicator)]
[(string=? l ".") (reverse r)]
[(string=? l "..") (loop (cons "." r))]
[else (loop (cons l r))])))))
;; get-multi-line-response :
;; communicator -> number x string x list (string)
;; -- The returned values are the status code, the rest of the status
;; response line, and the remaining lines.
(define (get-multi-line-response communicator)
(let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)])
(let-values ([(code rest-of-line)
(parse-status-line status-line)])
(values code rest-of-line (get-rest-of-multi-line-response communicator)))))
;; open-news-group :
;; communicator x string -> number x number x number
;; -- The returned values are the number of articles, the first
;; article number, and the last article number for that group.
(define (open-news-group communicator group-name)
(send-to-server communicator "GROUP ~a" group-name)
(let-values ([(code rest-of-line)
(get-single-line-response communicator)])
(case code
[(211)
(let ([match (map string->number
(cdr
(or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
((signal-error make-bad-newsgroup-line
"malformed newsgroup open response: ~s"
rest-of-line)
rest-of-line))))])
(let ([number-of-articles (car match)]
[first-article-number (cadr match)]
[last-article-number (caddr match)])
(values number-of-articles
first-article-number
last-article-number)))]
[(411)
((signal-error make-non-existent-group
"group ~s does not exist on server ~s"
group-name (communicator-server communicator))
group-name)]
[else
((signal-error make-unexpected-response
"unexpected group opening response: ~s" code)
code rest-of-line)])))
;; generic-message-command :
;; string x number -> communicator x (number U string) -> list (string)
(define (generic-message-command command ok-code)
(lambda (communicator message-index)
(send-to-server communicator (string-append command " ~a")
(if (number? message-index)
(number->string message-index)
message-index))
(let-values ([(code response)
(get-single-line-response communicator)])
(if (= code ok-code)
(get-rest-of-multi-line-response communicator)
(case code
[(423)
((signal-error make-article-not-in-group
"article id ~s not in group" message-index)
message-index)]
[(412)
((signal-error make-no-group-selected
"no group selected"))]
[(430)
((signal-error make-article-not-found
"no article id ~s found" message-index)
message-index)]
[else
((signal-error make-unexpected-response
"unexpected message access response: ~s" code)
code response)])))))
;; head-of-message :
;; communicator x (number U string) -> list (string)
(define head-of-message
(generic-message-command "HEAD" 221))
;; body-of-message :
;; communicator x (number U string) -> list (string)
(define body-of-message
(generic-message-command "BODY" 222))
;; newnews-since :
;; communicator x (number U string) -> list (string)
(define newnews-since
(generic-message-command "NEWNEWS" 230))
;; make-desired-header :
;; string -> desired
(define (make-desired-header raw-header)
(regexp
(string-append
"^"
(list->string
(apply append
(map (lambda (c)
(cond
[(char-lower-case? c)
(list #\[ (char-upcase c) c #\])]
[(char-upper-case? c)
(list #\[ c (char-downcase c) #\])]
[else
(list c)]))
(string->list raw-header))))
":")))
;; extract-desired-headers :
;; list (string) x list (desired) -> list (string)
(define (extract-desired-headers headers desireds)
(filter (lambda (header)
(ormap (lambda (matcher) (regexp-match matcher header))
desireds))
headers))
(provide nntp@)

392
collects/net/pop3-unit.rkt
View File

@ -1,390 +1,8 @@
#lang racket/unit
#lang racket/base
(require racket/tcp "pop3-sig.rkt")
(require racket/unit
"pop3-sig.rkt" "pop3.rkt")
(import)
(export pop3^)
(define-unit-from-context pop3@ pop3^)
;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
;; sender : oport
;; receiver : iport
;; server : string
;; port : number
;; state : symbol = (disconnected, authorization, transaction)
(define-struct communicator (sender receiver server port [state #:mutable]))
(define-struct (pop3 exn) ())
(define-struct (cannot-connect pop3) ())
(define-struct (username-rejected pop3) ())
(define-struct (password-rejected pop3) ())
(define-struct (not-ready-for-transaction pop3) (communicator))
(define-struct (not-given-headers pop3) (communicator message))
(define-struct (illegal-message-number pop3) (communicator message))
(define-struct (cannot-delete-message exn) (communicator message))
(define-struct (disconnect-not-quiet pop3) (communicator))
(define-struct (malformed-server-response pop3) (communicator))
;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> ()
(define (signal-error constructor format-string . args)
(lambda exn-args
(raise (apply constructor
(apply format format-string args)
(current-continuation-marks)
exn-args))))
;; signal-malformed-response-error :
;; exn-args -> ()
;; -- in practice, it takes only one argument: a communicator.
(define signal-malformed-response-error
(signal-error make-malformed-server-response
"malformed response from server"))
;; confirm-transaction-mode :
;; communicator x string -> ()
;; -- signals an error otherwise.
(define (confirm-transaction-mode communicator error-message)
(unless (eq? (communicator-state communicator) 'transaction)
((signal-error make-not-ready-for-transaction error-message)
communicator)))
;; default-pop-port-number :
;; number
(define default-pop-port-number 110)
(define-struct server-responses ())
(define-struct (+ok server-responses) ())
(define-struct (-err server-responses) ())
;; connect-to-server*:
;; input-port output-port -> communicator
(define connect-to-server*
(case-lambda
[(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")]
[(receiver sender server-name port-number)
(let ([communicator (make-communicator sender receiver server-name port-number
'authorization)])
(let ([response (get-status-response/basic communicator)])
(cond
[(+ok? response) communicator]
[(-err? response)
((signal-error make-cannot-connect
"cannot connect to ~a on port ~a"
server-name port-number))])))]))
;; connect-to-server :
;; string [x number] -> communicator
(define connect-to-server
(lambda (server-name (port-number default-pop-port-number))
(let-values ([(receiver sender) (tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number))))
;; authenticate/plain-text :
;; string x string x communicator -> ()
;; -- if authentication succeeds, sets the communicator's state to
;; transaction.
(define (authenticate/plain-text username password communicator)
(let ([sender (communicator-sender communicator)])
(send-to-server communicator "USER ~a" username)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(send-to-server communicator "PASS ~a" password)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(set-communicator-state! communicator 'transaction)]
[(-err? status)
((signal-error make-password-rejected
"password was rejected"))]))]
[(-err? status)
((signal-error make-username-rejected
"username was rejected"))]))))
;; get-mailbox-status :
;; communicator -> number x number
;; -- returns number of messages and number of octets.
(define (get-mailbox-status communicator)
(confirm-transaction-mode
communicator
"cannot get mailbox status unless in transaction mode")
(send-to-server communicator "STAT")
(apply values
(map string->number
(let-values ([(status result)
(get-status-response/match
communicator
#rx"([0-9]+) ([0-9]+)"
#f)])
result))))
;; get-message/complete :
;; communicator x number -> list (string) x list (string)
(define (get-message/complete communicator message)
(confirm-transaction-mode
communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "RETR ~a" message)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(split-header/body (get-multi-line-response communicator))]
[(-err? status)
((signal-error make-illegal-message-number
"not given message ~a" message)
communicator message)])))
;; get-message/headers :
;; communicator x number -> list (string)
(define (get-message/headers communicator message)
(confirm-transaction-mode
communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "TOP ~a 0" message)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(let-values ([(headers body)
(split-header/body
(get-multi-line-response communicator))])
headers)]
[(-err? status)
((signal-error make-not-given-headers
"not given headers to message ~a" message)
communicator message)])))
;; get-message/body :
;; communicator x number -> list (string)
(define (get-message/body communicator message)
(let-values ([(headers body) (get-message/complete communicator message)])
body))
;; split-header/body :
;; list (string) -> list (string) x list (string)
;; -- returns list of headers and list of body lines.
(define (split-header/body lines)
(let loop ([lines lines] [header null])
(if (null? lines)
(values (reverse header) null)
(let ([first (car lines)]
[rest (cdr lines)])
(if (string=? first "")
(values (reverse header) rest)
(loop rest (cons first header)))))))
;; delete-message :
;; communicator x number -> ()
(define (delete-message communicator message)
(confirm-transaction-mode
communicator
"cannot delete message unless in transaction state")
(send-to-server communicator "DELE ~a" message)
(let ([status (get-status-response/basic communicator)])
(cond
[(-err? status)
((signal-error make-cannot-delete-message
"no message numbered ~a available to be deleted" message)
communicator message)]
[(+ok? status)
'deleted])))
;; regexp for UIDL responses
(define uidl-regexp #rx"([0-9]+) (.*)")
;; get-unique-id/single :
;; communicator x number -> string
(define (get-unique-id/single communicator message)
(confirm-transaction-mode
communicator
"cannot get unique message id unless in transaction state")
(send-to-server communicator "UIDL ~a" message)
(let-values ([(status result)
(get-status-response/match communicator uidl-regexp ".*")])
;; The server response is of the form
;; +OK 2 QhdPYR:00WBw1Ph7x7
(cond
[(-err? status)
((signal-error make-illegal-message-number
"no message numbered ~a available for unique id" message)
communicator message)]
[(+ok? status)
(cadr result)])))
;; get-unique-id/all :
;; communicator -> list(number x string)
(define (get-unique-id/all communicator)
(confirm-transaction-mode communicator
"cannot get unique message ids unless in transaction state")
(send-to-server communicator "UIDL")
(let ([status (get-status-response/basic communicator)])
;; The server response is of the form
;; +OK
;; 1 whqtswO00WBw418f9t5JxYwZ
;; 2 QhdPYR:00WBw1Ph7x7
;; .
(map (lambda (l)
(let ([m (regexp-match uidl-regexp l)])
(cons (string->number (cadr m)) (caddr m))))
(get-multi-line-response communicator))))
;; close-communicator :
;; communicator -> ()
(define (close-communicator communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator)))
;; disconnect-from-server :
;; communicator -> ()
(define (disconnect-from-server communicator)
(send-to-server communicator "QUIT")
(set-communicator-state! communicator 'disconnected)
(let ([response (get-status-response/basic communicator)])
(close-communicator communicator)
(cond
[(+ok? response) (void)]
[(-err? response)
((signal-error make-disconnect-not-quiet
"got error status upon disconnect")
communicator)])))
;; send-to-server :
;; communicator x format-string x list (values) -> ()
(define (send-to-server communicator message-template . rest)
(apply fprintf (communicator-sender communicator)
(string-append message-template "\r\n")
rest)
(flush-output (communicator-sender communicator)))
;; get-one-line-from-server :
;; iport -> string
(define (get-one-line-from-server server->client-port)
(read-line server->client-port 'return-linefeed))
;; get-server-status-response :
;; communicator -> server-responses x string
;; -- provides the low-level functionality of checking for +OK
;; and -ERR, returning an appropriate structure, and returning the
;; rest of the status response as a string to be used for further
;; parsing, if necessary.
(define (get-server-status-response communicator)
(let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)]
[r (regexp-match #rx"^\\+OK(.*)" status-line)])
(if r
(values (make-+ok) (cadr r))
(let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
(if r
(values (make--err) (cadr r))
(signal-malformed-response-error communicator))))))
;; get-status-response/basic :
;; communicator -> server-responses
;; -- when the only thing to determine is whether the response
;; was +OK or -ERR.
(define (get-status-response/basic communicator)
(let-values ([(response rest)
(get-server-status-response communicator)])
response))
;; get-status-response/match :
;; communicator x regexp x regexp -> (status x list (string))
;; -- when further parsing of the status response is necessary.
;; Strips off the car of response from regexp-match.
(define (get-status-response/match communicator +regexp -regexp)
(let-values ([(response rest)
(get-server-status-response communicator)])
(if (and +regexp (+ok? response))
(let ([r (regexp-match +regexp rest)])
(if r (values response (cdr r))
(signal-malformed-response-error communicator)))
(if (and -regexp (-err? response))
(let ([r (regexp-match -regexp rest)])
(if r (values response (cdr r))
(signal-malformed-response-error communicator)))
(signal-malformed-response-error communicator)))))
;; get-multi-line-response :
;; communicator -> list (string)
(define (get-multi-line-response communicator)
(let ([receiver (communicator-receiver communicator)])
(let loop ()
(let ([l (get-one-line-from-server receiver)])
(cond
[(eof-object? l)
(signal-malformed-response-error communicator)]
[(string=? l ".")
'()]
[(and (> (string-length l) 1)
(char=? (string-ref l 0) #\.))
(cons (substring l 1 (string-length l)) (loop))]
[else
(cons l (loop))])))))
;; make-desired-header :
;; string -> desired
(define (make-desired-header raw-header)
(regexp
(string-append
"^"
(list->string
(apply append
(map (lambda (c)
(cond
[(char-lower-case? c)
(list #\[ (char-upcase c) c #\])]
[(char-upper-case? c)
(list #\[ c (char-downcase c) #\])]
[else
(list c)]))
(string->list raw-header))))
":")))
;; extract-desired-headers :
;; list (string) x list (desired) -> list (string)
(define (extract-desired-headers headers desireds)
(let loop ([headers headers])
(if (null? headers) null
(let ([first (car headers)]
[rest (cdr headers)])
(if (ormap (lambda (matcher)
(regexp-match matcher first))
desireds)
(cons first (loop rest))
(loop rest))))))
(provide pop3@)

167
collects/net/qp-unit.rkt
View File

@ -1,165 +1,8 @@
;;;
;;; <qp-unit.rkt> ---- Quoted Printable Implementation
;;;
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona.
;;;
;;; This file was part of mime-plt.
#lang racket/base
;;; mime-plt is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
(require racket/unit
"qp-sig.rkt" "qp.rkt")
;;; mime-plt is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
(define-unit-from-context qp@ qp^)
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with mime-plt; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA.
;;; Author: Francisco Solsona <solsona@acm.org>
;;
;;
;; Commentary:
#lang racket/unit
(require "qp-sig.rkt")
(import)
(export qp^)
;; Exceptions:
;; String or input-port expected:
(define-struct qp-error ())
(define-struct (qp-wrong-input qp-error) ())
(define-struct (qp-wrong-line-size qp-error) (size))
;; qp-encode : bytes -> bytes
;; returns the quoted printable representation of STR.
(define (qp-encode str)
(let ([out (open-output-bytes)])
(qp-encode-stream (open-input-bytes str) out #"\r\n")
(get-output-bytes out)))
;; qp-decode : string -> string
;; returns STR unqp.
(define (qp-decode str)
(let ([out (open-output-bytes)])
(qp-decode-stream (open-input-bytes str) out)
(get-output-bytes out)))
(define (qp-decode-stream in out)
(let loop ([ch (read-byte in)])
(unless (eof-object? ch)
(case ch
[(61) ;; A "=", which is quoted-printable stuff
(let ([next (read-byte in)])
(cond
[(eq? next 10)
;; Soft-newline -- drop it
(void)]
[(eq? next 13)
;; Expect a newline for a soft CRLF...
(let ([next-next (read-byte in)])
(if (eq? next-next 10)
;; Good.
(loop (read-byte in))
;; Not a LF? Well, ok.
(loop next-next)))]
[(hex-digit? next)
(let ([next-next (read-byte in)])
(cond [(eof-object? next-next)
(warning "Illegal qp sequence: `=~a'" next)
(display "=" out)
(display next out)]
[(hex-digit? next-next)
;; qp-encoded
(write-byte (hex-bytes->byte next next-next)
out)]
[else
(warning "Illegal qp sequence: `=~a~a'" next next-next)
(write-byte 61 out)
(write-byte next out)
(write-byte next-next out)]))]
[else
;; Warning: invalid
(warning "Illegal qp sequence: `=~a'" next)
(write-byte 61 out)
(write-byte next out)])
(loop (read-byte in)))]
[else
(write-byte ch out)
(loop (read-byte in))]))))
(define (warning msg . args)
(when #f
(fprintf (current-error-port)
(apply format msg args))
(newline (current-error-port))))
(define (hex-digit? i)
(vector-ref hex-values i))
(define (hex-bytes->byte b1 b2)
(+ (* 16 (vector-ref hex-values b1))
(vector-ref hex-values b2)))
(define (write-hex-bytes byte p)
(write-byte 61 p)
(write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
(write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p))
(define (qp-encode-stream in out [newline-string #"\n"])
(let loop ([col 0])
(if (= col 75)
(begin
;; Soft newline:
(write-byte 61 out)
(display newline-string out)
(loop 0))
(let ([i (read-byte in)])
(cond
[(eof-object? i) (void)]
[(or (= i 10) (= i 13))
(write-byte i out)
(loop 0)]
[(or (<= 33 i 60) (<= 62 i 126)
(and (or (= i 32) (= i 9))
(not (let ([next (peek-byte in)])
(or (eof-object? next) (= next 10) (= next 13))))))
;; single-byte mode:
(write-byte i out)
(loop (add1 col))]
[(>= col 73)
;; need a soft newline first
(write-byte 61 out)
(display newline-string out)
;; now the octect
(write-hex-bytes i out)
(loop 3)]
[else
;; an octect
(write-hex-bytes i out)
(loop (+ col 3))])))))
;; Tables
(define hex-values (make-vector 256 #f))
(define hex-bytes (make-vector 16))
(let loop ([i 0])
(unless (= i 10)
(vector-set! hex-values (+ i 48) i)
(vector-set! hex-bytes i (+ i 48))
(loop (add1 i))))
(let loop ([i 0])
(unless (= i 6)
(vector-set! hex-values (+ i 65) (+ 10 i))
(vector-set! hex-values (+ i 97) (+ 10 i))
(vector-set! hex-bytes (+ 10 i) (+ i 65))
(loop (add1 i))))
;;; qp-unit.rkt ends here
(provide qp@)

121
collects/net/sendmail-unit.rkt
View File

@ -1,119 +1,8 @@
#lang racket/unit
#lang racket/base
(require racket/system "sendmail-sig.rkt")
(require racket/unit
"sendmail-sig.rkt" "sendmail.rkt")
(import)
(export sendmail^)
(define-unit-from-context sendmail@ sendmail^)
(define-struct (no-mail-recipients exn) ())
(define sendmail-search-path
'("/usr/lib" "/usr/sbin"))
(define sendmail-program-file
(if (or (eq? (system-type) 'unix)
(eq? (system-type) 'macosx))
(let loop ([paths sendmail-search-path])
(if (null? paths)
(raise (make-exn:fail:unsupported
"unable to find sendmail on this Unix variant"
(current-continuation-marks)))
(let ([p (build-path (car paths) "sendmail")])
(if (and (file-exists? p)
(memq 'execute (file-or-directory-permissions p)))
p
(loop (cdr paths))))))
(raise (make-exn:fail:unsupported
"sendmail only available under Unix"
(current-continuation-marks)))))
;; send-mail-message/port :
;; string x string x list (string) x list (string) x list (string)
;; [x list (string)] -> oport
;; -- sender can be anything, though spoofing is not recommended.
;; The recipients must all be pure email addresses. Note that
;; everything is expected to follow RFC conventions. If any other
;; headers are specified, they are expected to be completely
;; formatted already. Clients are urged to use close-output-port on
;; the port returned by this procedure as soon as the necessary text
;; has been written, so that the sendmail process can complete.
(define (send-mail-message/port
sender subject to-recipients cc-recipients bcc-recipients
. other-headers)
(when (and (null? to-recipients) (null? cc-recipients)
(null? bcc-recipients))
(raise (make-no-mail-recipients
"no mail recipients were specified"
(current-continuation-marks))))
(let ([return (apply process* sendmail-program-file "-i"
(append to-recipients cc-recipients bcc-recipients))])
(let ([reader (car return)]
[writer (cadr return)]
[pid (caddr return)]
[error-reader (cadddr return)])
(close-input-port reader)
(close-input-port error-reader)
(fprintf writer "From: ~a\n" sender)
(letrec ([write-recipient-header
(lambda (header-string recipients)
(let ([header-space
(+ (string-length header-string) 2)])
(fprintf writer "~a: " header-string)
(let loop ([to recipients] [indent header-space])
(if (null? to)
(newline writer)
(let ([first (car to)]
[rest (cdr to)])
(let ([len (string-length first)])
(if (>= (+ len indent) 80)
(begin
(fprintf writer
(if (null? rest)
"\n ~a"
"\n ~a, ")
first)
(loop (cdr to)
(+ len header-space 2)))
(begin
(fprintf writer
(if (null? rest)
"~a "
"~a, ")
first)
(loop (cdr to)
(+ len indent 2))))))))))])
(write-recipient-header "To" to-recipients)
(unless (null? cc-recipients)
(write-recipient-header "CC" cc-recipients)))
(fprintf writer "Subject: ~a\n" subject)
(fprintf writer "X-Mailer: Racket (racket-lang.org)\n")
(for-each (lambda (s)
(display s writer)
(newline writer))
other-headers)
(newline writer)
writer)))
;; send-mail-message :
;; string x string x list (string) x list (string) x list (string) x
;; list (string) [x list (string)] -> ()
;; -- sender can be anything, though spoofing is not recommended. The
;; recipients must all be pure email addresses. The text is expected
;; to be pre-formatted. Note that everything is expected to follow
;; RFC conventions. If any other headers are specified, they are
;; expected to be completely formatted already.
(define (send-mail-message
sender subject to-recipients cc-recipients bcc-recipients text
. other-headers)
(let ([writer (apply send-mail-message/port sender subject
to-recipients cc-recipients bcc-recipients
other-headers)])
(for-each (lambda (s)
(display s writer) ; We use -i, so "." is not a problem
(newline writer))
text)
(close-output-port writer)))
(provide sendmail@)

166
collects/net/smtp-unit.rkt
View File

@ -1,164 +1,8 @@
#lang racket/unit
#lang racket/base
(require racket/tcp "base64.rkt" "smtp-sig.rkt")
(require racket/unit
"smtp-sig.rkt" "smtp.rkt")
(import)
(export smtp^)
(define-unit-from-context smtp@ smtp^)
(define smtp-sending-server (make-parameter "localhost"))
(define debug-via-stdio? #f)
;; (define log printf)
(define log void)
(define (starts-with? l n)
(and (>= (string-length l) (string-length n))
(string=? n (substring l 0 (string-length n)))))
(define (check-reply/accum r v w a)
(flush-output w)
(let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))])
(log "server: ~a\n" l)
(if (eof-object? l)
(error 'check-reply "got EOF")
(let ([n (number->string v)])
(unless (starts-with? l n)
(error 'check-reply "expected reply ~a; got: ~a" v l))
(let ([n- (string-append n "-")])
(if (starts-with? l n-)
;; Multi-line reply. Go again.
(check-reply/accum r v w (if a (cons (substring l 4) a) #f))
;; We're finished, so add the last and reverse the result
(when a
(reverse (cons (substring l 4) a)))))))))
(define (check-reply/commands r v w . commands)
;; drop the first response, which is just the flavor text -- we expect the rest to
;; be a list of supported ESMTP commands.
(let ([cmdlist (cdr (check-reply/accum r v w '()))])
(for-each (lambda (c1)
(unless (findf (lambda (c2) (string=? c1 c2)) cmdlist)
(error "expected advertisement of ESMTP command ~a" c1)))
commands)))
(define (check-reply r v w)
(check-reply/accum r v w #f))
(define (protect-line l)
;; If begins with a dot, add one more
(if (or (equal? l #"")
(equal? l "")
(and (string? l)
(not (char=? #\. (string-ref l 0))))
(and (bytes? l)
(not (= (char->integer #\.) (bytes-ref l 0)))))
l
(if (bytes? l)
(bytes-append #"." l)
(string-append "." l))))
(define smtp-sending-end-of-message
(make-parameter void
(lambda (f)
(unless (and (procedure? f)
(procedure-arity-includes? f 0))
(raise-type-error 'smtp-sending-end-of-message "thunk" f))
f)))
(define (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd tls-encode)
(with-handlers ([void (lambda (x)
(close-input-port r)
(close-output-port w)
(raise x))])
(check-reply r 220 w)
(log "hello\n")
(fprintf w "EHLO ~a\r\n" (smtp-sending-server))
(when tls-encode
(check-reply/commands r 250 w "STARTTLS")
(log "starttls\n")
(fprintf w "STARTTLS\r\n")
(check-reply r 220 w)
(let-values ([(ssl-r ssl-w)
(tls-encode r w
#:mode 'connect
#:encrypt 'tls
#:close-original? #t)])
(set! r ssl-r)
(set! w ssl-w))
;; According to RFC 3207 Sec 4.2, we must start anew with the EHLO.
(log "tls hello\n")
(fprintf w "EHLO ~a\r\n" (smtp-sending-server)))
(check-reply r 250 w)
(when auth-user
(log "auth\n")
(fprintf w "AUTH PLAIN ~a"
;; Encoding adds CRLF
(base64-encode
(string->bytes/latin-1
(format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
(check-reply r 235 w))
(log "from\n")
(fprintf w "MAIL FROM:<~a>\r\n" sender)
(check-reply r 250 w)
(log "to\n")
(for-each
(lambda (dest)
(fprintf w "RCPT TO:<~a>\r\n" dest)
(check-reply r 250 w))
recipients)
(log "header\n")
(fprintf w "DATA\r\n")
(check-reply r 354 w)
(fprintf w "~a" header)
(for-each
(lambda (l)
(log "body: ~a\n" l)
(fprintf w "~a\r\n" (protect-line l)))
message-lines)
;; After we send the ".", then only break in an emergency
((smtp-sending-end-of-message))
(log "dot\n")
(fprintf w ".\r\n")
(flush-output w)
(check-reply r 250 w)
;; Once a 250 has been received in response to the . at the end of
;; the DATA block, the email has been sent successfully and out of our
;; hands. This function should thus indicate success at this point
;; no matter what else happens.
;;
;; Some servers (like smtp.gmail.com) will just close the connection
;; on a QUIT, so instead of causing any QUIT errors to look like the
;; email failed, we'll just log them.
(with-handlers ([void (lambda (x)
(log "error after send: ~a\n" (exn-message x)))])
(log "quit\n")
(fprintf w "QUIT\r\n")
(check-reply r 221 w))
(close-output-port w)
(close-input-port r)))
(define smtp-send-message
(lambda (server sender recipients header message-lines
#:port-no [port-no 25]
#:auth-user [auth-user #f]
#:auth-passwd [auth-passwd #f]
#:tcp-connect [tcp-connect tcp-connect]
#:tls-encode [tls-encode #f]
[opt-port-no port-no])
(when (null? recipients)
(error 'send-smtp-message "no receivers"))
(let-values ([(r w) (if debug-via-stdio?
(values (current-input-port) (current-output-port))
(tcp-connect server opt-port-no))])
(smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd tls-encode))))
(provide smtp@)

292
collects/net/uri-codec-unit.rkt
View File

@ -1,290 +1,8 @@
#|
#lang racket/base
People used to wonder why semicolons were the default. We then
decided to switch the default back to ampersands --
(require racket/unit
"uri-codec-sig.rkt" "uri-codec.rkt")
http://www.w3.org/TR/html401/appendix/notes.html#h-B.2.2
(define-unit-from-context uri-codec@ uri-codec^)
We recommend that HTTP server implementors, and in particular, CGI
implementors support the use of ";" in place of "&" to save authors
the trouble of escaping "&" characters in this manner.
See more in PR8831.
|#
;;;
;;; <uri-codec-unit.rkt> ---- En/Decode URLs and form-urlencoded data
;;; Time-stamp: <03/04/25 10:31:31 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of Net.
;;; Net is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;; Net is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with Net; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA.
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; The module provides functions to encode and decode strings using
;; the URI encoding rules given in RFC 2396, and to encode and decode
;; name/value pairs using the application/x-www-form-urlencoded
;; mimetype given the in HTML 4.0 specification. There are minor
;; differences between the two encodings.
;; The URI encoding uses allows a few characters to be represented `as
;; is': a-Z, A-Z, 0-9, -, _, ., !, ~, *, ', ( and ). The remaining
;; characters are encoded as %xx, where xx is the hex representation
;; of the integer value of the character (where the mapping
;; character<->integer is determined by US-ASCII if the integer is
;; <128).
;; The encoding, inline with RFC 2396's recommendation, represents a
;; character as is, if possible. The decoding allows any characters
;; to be represented by their hex values, and allows characters to be
;; incorrectly represented `as is'.
;; The rules for the application/x-www-form-urlencoded mimetype given
;; in the HTML 4.0 spec are:
;; 1. Control names and values are escaped. Space characters are
;; replaced by `+', and then reserved characters are escaped as
;; described in [RFC1738], section 2.2: Non-alphanumeric characters
;; are replaced by `%HH', a percent sign and two hexadecimal digits
;; representing the ASCII code of the character. Line breaks are
;; represented as "CR LF" pairs (i.e., `%0D%0A').
;; 2. The control names/values are listed in the order they appear
;; in the document. The name is separated from the value by `=' and
;; name/value pairs are separated from each other by `&'.
;; NB: RFC 2396 supersedes RFC 1738.
;; This differs slightly from the straight encoding in RFC 2396 in
;; that `+' is allowed, and represents a space. We follow this
;; convention, encoding a space as `+' and decoding `+' as a space.
;; There appear to be some brain-dead decoders on the web, so we also
;; encode `!', `~', `'', `(' and ')' using their hex representation.
;; This is the same choice as made by the Java URLEncoder.
;; Draws inspiration from encode-decode.scm by Kurt Normark and a code
;; sample provided by Eli Barzilay
#lang racket/unit
(require racket/match racket/string racket/list "uri-codec-sig.rkt")
(import)
(export uri-codec^)
(define (self-map-char ch) (cons ch ch))
(define (self-map-chars str) (map self-map-char (string->list str)))
;; The characters that always map to themselves
(define alphanumeric-mapping
(self-map-chars
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
;; Characters that sometimes map to themselves
;; called 'mark' in RFC 3986
(define safe-mapping (self-map-chars "-_.!~*'()"))
;; The strict URI mapping
(define uri-mapping (append alphanumeric-mapping safe-mapping))
;; The uri path segment mapping from RFC 3986
(define uri-path-segment-mapping
(append alphanumeric-mapping
safe-mapping
(self-map-chars "@+,=$&:")))
;; from RFC 3986
(define unreserved-mapping
(append alphanumeric-mapping
(self-map-chars "-._~")))
;; from RFC 3986
(define sub-delims-mapping
(self-map-chars "!$&'()*+,;="))
;; The uri userinfo mapping from RFC 3986
(define uri-userinfo-mapping
(append unreserved-mapping
sub-delims-mapping
(self-map-chars ":")))
;; The form-urlencoded mapping
(define form-urlencoded-mapping
`(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping))
(define (number->hex-string number)
(define (hex n) (string-ref "0123456789ABCDEF" n))
(string #\% (hex (quotient number 16)) (hex (modulo number 16))))
(define (hex-string->number hex-string)
(string->number (substring hex-string 1 3) 16))
(define ascii-size 128)
;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
(define (make-codec-tables alist)
(let ([encoding-table (build-vector ascii-size number->hex-string)]
[decoding-table (build-vector ascii-size values)])
(for-each (match-lambda
[(cons orig enc)
(vector-set! encoding-table
(char->integer orig)
(string enc))
(vector-set! decoding-table
(char->integer enc)
(char->integer orig))])
alist)
(values encoding-table decoding-table)))
(define-values (uri-encoding-vector uri-decoding-vector)
(make-codec-tables uri-mapping))
(define-values (uri-path-segment-encoding-vector
uri-path-segment-decoding-vector)
(make-codec-tables uri-path-segment-mapping))
(define-values (uri-userinfo-encoding-vector
uri-userinfo-decoding-vector)
(make-codec-tables uri-userinfo-mapping))
(define-values (form-urlencoded-encoding-vector
form-urlencoded-decoding-vector)
(make-codec-tables form-urlencoded-mapping))
;; vector string -> string
(define (encode table str)
(apply string-append (map (lambda (byte)
(if (< byte ascii-size)
(vector-ref table byte)
(number->hex-string byte)))
(bytes->list (string->bytes/utf-8 str)))))
;; vector string -> string
(define (decode table str)
(define internal-decode
(match-lambda [(list) (list)]
[(list* #\% (? hex-digit? char1) (? hex-digit? char2) rest)
;; This used to consult the table again, but I think that's
;; wrong. For example %2b should produce +, not a space.
(cons (string->number (string char1 char2) 16)
(internal-decode rest))]
[(cons (? ascii-char? char) rest)
(cons (vector-ref table (char->integer char))
(internal-decode rest))]
[(cons char rest)
(append
(bytes->list (string->bytes/utf-8 (string char)))
(internal-decode rest))]))
(bytes->string/utf-8 (apply bytes (internal-decode (string->list str)))))
(define (ascii-char? c)
(< (char->integer c) ascii-size))
(define (hex-digit? c)
(or (char<=? #\0 c #\9)
(char<=? #\a c #\f)
(char<=? #\A c #\F)))
;; string -> string
(define (uri-encode str)
(encode uri-encoding-vector str))
;; string -> string
(define (uri-decode str)
(decode uri-decoding-vector str))
;; string -> string
(define (uri-path-segment-encode str)
(encode uri-path-segment-encoding-vector str))
;; string -> string
(define (uri-path-segment-decode str)
(decode uri-path-segment-decoding-vector str))
;; string -> string
(define (uri-userinfo-encode str)
(encode uri-userinfo-encoding-vector str))
;; string -> string
(define (uri-userinfo-decode str)
(decode uri-userinfo-decoding-vector str))
;; string -> string
(define (form-urlencoded-encode str)
(encode form-urlencoded-encoding-vector str))
;; string -> string
(define (form-urlencoded-decode str)
(decode form-urlencoded-decoding-vector str))
;; listof (cons string string) -> string
;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
;; listof (cons symbol string) -> string
(define (alist->form-urlencoded args)
(let* ([sep (if (memq (current-alist-separator-mode) '(semi semi-or-amp))
";" "&")]
[format-one
(lambda (arg)
(let* ([name (car arg)]
[value (cdr arg)]
[name (form-urlencoded-encode (symbol->string name))]
[value (and value (form-urlencoded-encode value))])
(if value (string-append name "=" value) name)))]
[strs (if (null? args)
'()
(cons (format-one (car args))
(apply append
(map (lambda (a) (list sep (format-one a)))
(cdr args)))))])
(apply string-append strs)))
;; string -> listof (cons string string)
;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
(define (form-urlencoded->alist str)
(define keyval-regexp #rx"=")
(define value-regexp
(case (current-alist-separator-mode)
[(semi) #rx"[;]"]
[(amp) #rx"[&]"]
[else #rx"[&;]"]))
(define (parse-keyval keyval)
(let (;; m = #f => no "=..." part
[m (regexp-match-positions keyval-regexp keyval)])
(cons (string->symbol (form-urlencoded-decode
(if m (substring keyval 0 (caar m)) keyval)))
(and m (form-urlencoded-decode (substring keyval (cdar m)))))))
(if (equal? "" str) '() (map parse-keyval (regexp-split value-regexp str))))
(define current-alist-separator-mode
(make-parameter 'amp-or-semi
(lambda (s)
(unless (memq s '(amp semi amp-or-semi semi-or-amp))
(raise-type-error 'current-alist-separator-mode
"'amp, 'semi, 'amp-or-semi, or 'semi-or-amp"
s))
s)))
;;; uri-codec-unit.rkt ends here
(provide uri-codec@)

610
collects/net/url-unit.rkt
View File

@ -1,608 +1,8 @@
#lang racket/unit
#lang racket/base
;; To do:
;; Handle HTTP/file errors.
;; Not throw away MIME headers.
;; Determine file type.
(require racket/unit
"url-sig.rkt" "url.rkt" "url-connect.rkt")
;; ----------------------------------------------------------------------
(define-unit-from-context url@ url+scheme^)
;; Input ports have two statuses:
;; "impure" = they have text waiting
;; "pure" = the MIME headers have been read
(require racket/port racket/string
"url-structs.rkt" "uri-codec.rkt" "url-sig.rkt" "tcp-sig.rkt")
(import tcp^)
(export url+scheme^)
(define-struct (url-exception exn:fail) ())
(define file-url-path-convention-type (make-parameter (system-path-convention-type)))
(define current-proxy-servers
(make-parameter null
(lambda (v)
(unless (and (list? v)
(andmap (lambda (v)
(and (list? v)
(= 3 (length v))
(equal? (car v) "http")
(string? (car v))
(exact-integer? (caddr v))
(<= 1 (caddr v) 65535)))
v))
(raise-type-error
'current-proxy-servers
"list of list of scheme, string, and exact integer in [1,65535]"
v))
(map (lambda (v)
(list (string->immutable-string (car v))
(string->immutable-string (cadr v))
(caddr v)))
v))))
(define (url-error fmt . args)
(raise (make-url-exception
(apply format fmt
(map (lambda (arg) (if (url? arg) (url->string arg) arg))
args))
(current-continuation-marks))))
(define (url->string url)
(let ([scheme (url-scheme url)]
[user (url-user url)]
[host (url-host url)]
[port (url-port url)]
[path (url-path url)]
[query (url-query url)]
[fragment (url-fragment url)]
[sa string-append])
(when (and (equal? scheme "file")
(not (url-path-absolute? url)))
(raise-mismatch-error 'url->string
"cannot convert relative file URL to a string: "
url))
(sa (if scheme (sa scheme ":") "")
(if (or user host port)
(sa "//"
(if user (sa (uri-userinfo-encode user) "@") "")
(if host host "")
(if port (sa ":" (number->string port)) "")
;; There used to be a "/" here, but that causes an
;; extra leading slash -- wonder why it ever worked!
)
(if (equal? "file" scheme) ; always need "//" for "file" URLs
"//"
""))
(combine-path-strings (url-path-absolute? url) path)
;; (if query (sa "?" (uri-encode query)) "")
(if (null? query) "" (sa "?" (alist->form-urlencoded query)))
(if fragment (sa "#" (uri-encode fragment)) ""))))
;; url->default-port : url -> num
(define (url->default-port url)
(let ([scheme (url-scheme url)])
(cond [(not scheme) 80]
[(string=? scheme "http") 80]
[(string=? scheme "https") 443]
[else (url-error "URL scheme ~s not supported" scheme)])))
(define current-connect-scheme (make-parameter "http"))
;; make-ports : url -> in-port x out-port
(define (make-ports url proxy)
(let ([port-number (if proxy
(caddr proxy)
(or (url-port url) (url->default-port url)))]
[host (if proxy (cadr proxy) (url-host url))])
(parameterize ([current-connect-scheme (url-scheme url)])
(tcp-connect host port-number))))
;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port
(define (http://getpost-impure-port get? url post-data strings)
(define proxy (assoc (url-scheme url) (current-proxy-servers)))
(define-values (server->client client->server) (make-ports url proxy))
(define access-string
(url->string
(if proxy
url
;; RFCs 1945 and 2616 say:
;; Note that the absolute path cannot be empty; if none is present in
;; the original URI, it must be given as "/" (the server root).
(let-values ([(abs? path)
(if (null? (url-path url))
(values #t (list (make-path/param "" '())))
(values (url-path-absolute? url) (url-path url)))])
(make-url #f #f #f #f abs? path (url-query url) (url-fragment url))))))
(define (println . xs)
(for-each (lambda (x) (display x client->server)) xs)
(display "\r\n" client->server))
(println (if get? "GET " "POST ") access-string " HTTP/1.0")
(println "Host: " (url-host url)
(let ([p (url-port url)]) (if p (format ":~a" p) "")))
(when post-data (println "Content-Length: " (bytes-length post-data)))
(for-each println strings)
(println)
(when post-data (display post-data client->server))
(flush-output client->server)
(tcp-abandon-port client->server)
server->client)
(define (file://->path url [kind (system-path-convention-type)])
(let ([strs (map path/param-path (url-path url))]
[string->path-element/same
(lambda (e)
(if (symbol? e)
e
(if (string=? e "")
'same
(bytes->path-element (string->bytes/locale e) kind))))]
[string->path/win (lambda (s)
(bytes->path (string->bytes/utf-8 s) 'windows))])
(if (and (url-path-absolute? url)
(eq? 'windows kind))
;; If initial path is "", then build UNC path.
(cond
[(not (url-path-absolute? url))
(apply build-path (map string->path-element/same strs))]
[(and ((length strs) . >= . 3)
(equal? (car strs) ""))
(apply build-path
(string->path/win
(string-append "\\\\" (cadr strs) "\\" (caddr strs) "\\"))
(map string->path-element/same (cdddr strs)))]
[(pair? strs)
(apply build-path (string->path/win (car strs))
(map string->path-element/same (cdr strs)))]
[else (error 'file://->path "no path elements: ~e" url)])
(let ([elems (map string->path-element/same strs)])
(if (url-path-absolute? url)
(apply build-path (bytes->path #"/" 'unix) elems)
(apply build-path elems))))))
;; file://get-pure-port : url -> in-port
(define (file://get-pure-port url)
(open-input-file (file://->path url)))
(define (schemeless-url url)
(url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
;; getpost-impure-port : bool x url x list (str) -> in-port
(define (getpost-impure-port get? url post-data strings)
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http") (string=? scheme "https"))
(http://getpost-impure-port get? url post-data strings)]
[(string=? scheme "file")
(url-error "There are no impure file: ports")]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; get-impure-port : url [x list (str)] -> in-port
(define (get-impure-port url [strings '()])
(getpost-impure-port #t url #f strings))
;; post-impure-port : url x bytes [x list (str)] -> in-port
(define (post-impure-port url post-data [strings '()])
(getpost-impure-port #f url post-data strings))
;; getpost-pure-port : bool x url x list (str) -> in-port
(define (getpost-pure-port get? url post-data strings)
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
(let ([port (http://getpost-impure-port
get? url post-data strings)])
(purify-http-port port))]
[(string=? scheme "file")
(file://get-pure-port url)]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; get-pure-port : url [x list (str)] -> in-port
(define (get-pure-port url [strings '()])
(getpost-pure-port #t url #f strings))
;; post-pure-port : url bytes [x list (str)] -> in-port
(define (post-pure-port url post-data [strings '()])
(getpost-pure-port #f url post-data strings))
;; display-pure-port : in-port -> ()
(define (display-pure-port server->client)
(copy-port server->client (current-output-port))
(close-input-port server->client))
;; transliteration of code in rfc 3986, section 5.2.2
(define (combine-url/relative Base string)
(let ([R (string->url string)]
[T (make-url #f #f #f #f #f '() '() #f)])
(if (url-scheme R)
(begin
(set-url-scheme! T (url-scheme R))
(set-url-user! T (url-user R)) ;; authority
(set-url-host! T (url-host R)) ;; authority
(set-url-port! T (url-port R)) ;; authority
(set-url-path-absolute?! T (url-path-absolute? R))
(set-url-path! T (remove-dot-segments (url-path R)))
(set-url-query! T (url-query R)))
(begin
(if (url-host R) ;; => authority is defined
(begin
(set-url-user! T (url-user R)) ;; authority
(set-url-host! T (url-host R)) ;; authority
(set-url-port! T (url-port R)) ;; authority
(set-url-path-absolute?! T (url-path-absolute? R))
(set-url-path! T (remove-dot-segments (url-path R)))
(set-url-query! T (url-query R)))
(begin
(if (null? (url-path R)) ;; => R has empty path
(begin
(set-url-path-absolute?! T (url-path-absolute? Base))
(set-url-path! T (url-path Base))
(if (not (null? (url-query R)))
(set-url-query! T (url-query R))
(set-url-query! T (url-query Base))))
(begin
(cond
[(url-path-absolute? R)
(set-url-path-absolute?! T #t)
(set-url-path! T (remove-dot-segments (url-path R)))]
[(and (null? (url-path Base))
(url-host Base))
(set-url-path-absolute?! T #t)
(set-url-path! T (remove-dot-segments (url-path R)))]
[else
(set-url-path-absolute?! T (url-path-absolute? Base))
(set-url-path! T (remove-dot-segments
(append (all-but-last (url-path Base))
(url-path R))))])
(set-url-query! T (url-query R))))
(set-url-user! T (url-user Base)) ;; authority
(set-url-host! T (url-host Base)) ;; authority
(set-url-port! T (url-port Base)))) ;; authority
(set-url-scheme! T (url-scheme Base))))
(set-url-fragment! T (url-fragment R))
T))
(define (all-but-last lst)
(cond [(null? lst) null]
[(null? (cdr lst)) null]
[else (cons (car lst) (all-but-last (cdr lst)))]))
;; cribbed from 5.2.4 in rfc 3986
;; the strange [*] cases implicitly change urls
;; with paths segments "." and ".." at the end
;; into "./" and "../" respectively
(define (remove-dot-segments path)
(let loop ([path path] [result '()])
(if (null? path)
(reverse result)
(let ([fst (path/param-path (car path))]
[rst (cdr path)])
(loop rst
(cond
[(and (eq? fst 'same) (null? rst))
(cons (make-path/param "" '()) result)] ; [*]
[(eq? fst 'same)
result]
[(and (eq? fst 'up) (null? rst) (not (null? result)))
(cons (make-path/param "" '()) (cdr result))] ; [*]
[(and (eq? fst 'up) (not (null? result)))
(cdr result)]
[(and (eq? fst 'up) (null? result))
;; when we go up too far, just drop the "up"s.
result]
[else
(cons (car path) result)]))))))
;; call/input-url : url x (url -> in-port) x (in-port -> T)
;; [x list (str)] -> T
(define call/input-url
(let ([handle-port
(lambda (server->client handler)
(dynamic-wind (lambda () 'do-nothing)
(lambda () (handler server->client))
(lambda () (close-input-port server->client))))])
(case-lambda
[(url getter handler)
(handle-port (getter url) handler)]
[(url getter handler params)
(handle-port (getter url params) handler)])))
;; purify-port : in-port -> header-string
(define (purify-port port)
(let ([m (regexp-match-peek-positions
#rx"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)" port)])
(if m (read-string (cdar m) port) "")))
;; purify-http-port : in-port -> in-port
;; returns a new port, closes the old one when done pumping
(define (purify-http-port in-port)
(define-values (in-pipe out-pipe) (make-pipe))
(thread
(λ ()
(define status (http-read-status in-port))
(define chunked? (http-read-headers in-port))
(http-pipe-data chunked? in-port out-pipe)
(close-input-port in-port)))
in-pipe)
(define (http-read-status ip)
(read-line ip 'return-linefeed))
(define (http-read-headers ip)
(define l (read-line ip 'return-linefeed))
(when (eof-object? l)
(error 'purify-http-port "Connection ended before headers ended"))
(if (string=? l "")
#f
(if (string=? l "Transfer-Encoding: chunked")
(begin (http-read-headers ip)
#t)
(http-read-headers ip))))
(define (http-pipe-data chunked? ip op)
(if chunked?
(http-pipe-chunk ip op)
(begin
(copy-port ip op)
(flush-output op)
(close-output-port op))))
(define (http-pipe-chunk ip op)
(define size-str (read-line ip 'return-linefeed))
(define chunk-size (string->number size-str 16))
(unless chunk-size
(error 'http-pipe-chunk "Could not parse ~S as hexadecimal number" size-str))
(if (zero? chunk-size)
(begin (flush-output op)
(close-output-port op))
(let* ([bs (read-bytes chunk-size ip)]
[crlf (read-bytes 2 ip)])
(write-bytes bs op)
(http-pipe-chunk ip op))))
(define character-set-size 256)
;; netscape/string->url : str -> url
(define (netscape/string->url string)
(let ([url (string->url string)])
(cond [(url-scheme url) url]
[(string=? string "")
(url-error "Can't resolve empty string as URL")]
[else (set-url-scheme! url
(if (char=? (string-ref string 0) #\/) "file" "http"))
url])))
;; URL parsing regexp
;; this is following the regexp in Appendix B of rfc 3986, except for using
;; `*' instead of `+' for the scheme part (it is checked later anyway, and
;; we don't want to parse it as a path element), and the user@host:port is
;; parsed here.
(define url-rx
(regexp (string-append
"^"
"(?:" ; / scheme-colon-opt
"([^:/?#]*)" ; | #1 = scheme-opt
":)?" ; \
"(?://" ; / slash-slash-authority-opt
"(?:" ; | / user-at-opt
"([^/?#@]*)" ; | | #2 = user-opt
"@)?" ; | \
"([^/?#:]*)?" ; | #3 = host-opt
"(?::" ; | / colon-port-opt
"([0-9]*)" ; | | #4 = port-opt
")?" ; | \
")?" ; \
"([^?#]*)" ; #5 = path
"(?:\\?" ; / question-query-opt
"([^#]*)" ; | #6 = query-opt
")?" ; \
"(?:#" ; / hash-fragment-opt
"(.*)" ; | #7 = fragment-opt
")?" ; \
"$")))
;; string->url : str -> url
;; Original version by Neil Van Dyke
(define (string->url str)
(apply
(lambda (scheme user host port path query fragment)
(when (and scheme (not (regexp-match? #rx"^[a-zA-Z][a-zA-Z0-9+.-]*$"
scheme)))
(url-error "Invalid URL string; bad scheme ~e: ~e" scheme str))
;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
(let ([win-file? (and (or (equal? "" port) (not port))
(equal? "file" scheme)
(eq? 'windows (file-url-path-convention-type))
(not (equal? host "")))])
(when win-file?
(set! path (cond [(equal? "" port) (string-append host ":" path)]
[(and path host) (string-append host "/" path)]
[else (or path host)]))
(set! port #f)
(set! host ""))
(let* ([scheme (and scheme (string-downcase scheme))]
[host (and host (string-downcase host))]
[user (uri-decode/maybe user)]
[port (and port (string->number port))]
[abs? (or (equal? "file" scheme)
(regexp-match? #rx"^/" path))]
[path (if win-file?
(separate-windows-path-strings path)
(separate-path-strings path))]
[query (if query (form-urlencoded->alist query) '())]
[fragment (uri-decode/maybe fragment)])
(make-url scheme user host port abs? path query fragment))))
(cdr (or (regexp-match url-rx str)
(url-error "Invalid URL string: ~e" str)))))
(define (uri-decode/maybe f) (friendly-decode/maybe f uri-decode))
(define (friendly-decode/maybe f uri-decode)
;; If #f, and leave unmolested any % that is followed by hex digit
;; if a % is not followed by a hex digit, replace it with %25
;; in an attempt to be "friendly"
(and f (uri-decode (regexp-replace* #rx"%([^0-9a-fA-F])" f "%25\\1"))))
;; separate-path-strings : string[starting with /] -> (listof path/param)
(define (separate-path-strings str)
(let ([strs (regexp-split #rx"/" str)])
(map separate-params (if (string=? "" (car strs)) (cdr strs) strs))))
(define (separate-windows-path-strings str)
(url-path (path->url (bytes->path (string->bytes/utf-8 str) 'windows))))
(define (separate-params s)
(let ([lst (map path-segment-decode (regexp-split #rx";" s))])
(make-path/param (car lst) (cdr lst))))
(define (path-segment-decode p)
(cond [(string=? p "..") 'up]
[(string=? p ".") 'same]
[else (uri-path-segment-decode p)]))
(define (path-segment-encode p)
(cond [(eq? p 'up) ".."]
[(eq? p 'same) "."]
[(equal? p "..") "%2e%2e"]
[(equal? p ".") "%2e"]
[else (uri-path-segment-encode p)]))
(define (combine-path-strings absolute? path/params)
(cond [(null? path/params) ""]
[else (let ([p (string-join (map join-params path/params) "/")])
(if absolute? (string-append "/" p) p))]))
(define (join-params s)
(string-join (map path-segment-encode
(cons (path/param-path s) (path/param-param s)))
";"))
(define (path->url path)
(let ([url-path
(let loop ([path (simplify-path path #f)][accum null])
(let-values ([(base name dir?) (split-path path)])
(cond
[(not base)
(append (map
(lambda (s)
(make-path/param s null))
(if (eq? (path-convention-type path) 'windows)
;; For Windows, massage the root:
(let ([s (regexp-replace
#rx"[/\\\\]$"
(bytes->string/utf-8 (path->bytes name))
"")])
(cond
[(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
;; \\?\<drive>: path:
(regexp-split #rx"[/\\]+" (substring s 4))]
[(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s)
;; \\?\ UNC path:
(regexp-split #rx"[/\\]+" (substring s 7))]
[(regexp-match? #rx"^[/\\]" s)
;; UNC path:
(regexp-split #rx"[/\\]+" s)]
[else
(list s)]))
;; On other platforms, we drop the root:
null))
accum)]
[else
(let ([accum (cons (make-path/param
(if (symbol? name)
name
(bytes->string/utf-8
(path-element->bytes name)))
null)
accum)])
(if (eq? base 'relative)
accum
(loop base accum)))])))])
(make-url "file" #f "" #f (absolute-path? path) url-path '() #f)))
(define (url->path url [kind (system-path-convention-type)])
(file://->path url kind))
;; delete-pure-port : url [x list (str)] -> in-port
(define (delete-pure-port url [strings '()])
(method-pure-port 'delete url #f strings))
;; delete-impure-port : url [x list (str)] -> in-port
(define (delete-impure-port url [strings '()])
(method-impure-port 'delete url #f strings))
;; head-pure-port : url [x list (str)] -> in-port
(define (head-pure-port url [strings '()])
(method-pure-port 'head url #f strings))
;; head-impure-port : url [x list (str)] -> in-port
(define (head-impure-port url [strings '()])
(method-impure-port 'head url #f strings))
;; put-pure-port : url bytes [x list (str)] -> in-port
(define (put-pure-port url put-data [strings '()])
(method-pure-port 'put url put-data strings))
;; put-impure-port : url x bytes [x list (str)] -> in-port
(define (put-impure-port url put-data [strings '()])
(method-impure-port 'put url put-data strings))
;; method-impure-port : symbol x url x list (str) -> in-port
(define (method-impure-port method url data strings)
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http") (string=? scheme "https"))
(http://method-impure-port method url data strings)]
[(string=? scheme "file")
(url-error "There are no impure file: ports")]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; method-pure-port : symbol x url x list (str) -> in-port
(define (method-pure-port method url data strings)
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http") (string=? scheme "https"))
(let ([port (http://method-impure-port
method url data strings)])
(purify-http-port port))]
[(string=? scheme "file")
(file://get-pure-port url)]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; http://metod-impure-port : symbol x url x union (str, #f) x list (str) -> in-port
(define (http://method-impure-port method url data strings)
(let*-values
([(method) (case method
[(get) "GET"] [(post) "POST"] [(head) "HEAD"]
[(put) "PUT"] [(delete) "DELETE"]
[else (url-error "unsupported method: ~a" method)])]
[(proxy) (assoc (url-scheme url) (current-proxy-servers))]
[(server->client client->server) (make-ports url proxy)]
[(access-string) (url->string
(if proxy
url
(make-url #f #f #f #f
(url-path-absolute? url)
(url-path url)
(url-query url)
(url-fragment url))))])
(define (println . xs)
(for-each (lambda (x) (display x client->server)) xs)
(display "\r\n" client->server))
(println method " " access-string " HTTP/1.0")
(println "Host: " (url-host url)
(let ([p (url-port url)]) (if p (format ":~a" p) "")))
(when data (println "Content-Length: " (bytes-length data)))
(for-each println strings)
(println)
(when data (display data client->server))
(flush-output client->server)
(tcp-abandon-port client->server)
server->client))
(provide url@)

45
collects/racket/private/old-rp.rkt
View File

@ -5,28 +5,29 @@
(#%provide require require-for-syntax require-for-template require-for-label
provide provide-for-syntax provide-for-label)
(define-values-for-syntax (rebuild-elem)
(lambda (stx elem sub pos loop ids)
;; For sub-forms, we loop and reconstruct:
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"expected an identifier"
stx
id)))
(syntax->list ids))
(let rloop ([elem elem][pos pos])
(if (syntax? elem)
(datum->syntax elem
(rloop (syntax-e elem) pos)
elem
elem)
(if (zero? pos)
(cons (loop (car elem))
(cdr elem))
(cons (car elem)
(rloop (cdr elem) (sub1 pos))))))))
(begin-for-syntax
(define-values (rebuild-elem)
(lambda (stx elem sub pos loop ids)
;; For sub-forms, we loop and reconstruct:
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"expected an identifier"
stx
id)))
(syntax->list ids))
(let rloop ([elem elem][pos pos])
(if (syntax? elem)
(datum->syntax elem
(rloop (syntax-e elem) pos)
elem
elem)
(if (zero? pos)
(cons (loop (car elem))
(cdr elem))
(cons (car elem)
(rloop (cdr elem) (sub1 pos)))))))))
(define-syntaxes (require require-for-syntax require-for-template require-for-label)