diff --git a/collects/mzlib/include.rkt b/collects/mzlib/include.rkt
index 356f326..350efea 100644
--- a/collects/mzlib/include.rkt
+++ b/collects/mzlib/include.rkt
@@ -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
diff --git a/collects/mzlib/port.rkt b/collects/mzlib/port.rkt
index 7f32e6b..84fb89b 100644
--- a/collects/mzlib/port.rkt
+++ b/collects/mzlib/port.rkt
@@ -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)]
diff --git a/collects/mzlib/process.rkt b/collects/mzlib/process.rkt
index 259b91a..b897927 100644
--- a/collects/mzlib/process.rkt
+++ b/collects/mzlib/process.rkt
@@ -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))
diff --git a/collects/net/base64-unit.rkt b/collects/net/base64-unit.rkt
index 8fc1d28..6fa00d4 100644
--- a/collects/net/base64-unit.rkt
+++ b/collects/net/base64-unit.rkt
@@ -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@)
diff --git a/collects/net/cgi-sig.rkt b/collects/net/cgi-sig.rkt
index 8e54485..6ec6aac 100644
--- a/collects/net/cgi-sig.rkt
+++ b/collects/net/cgi-sig.rkt
@@ -20,4 +20,3 @@ get-cgi-method
;; -- general HTML utilities --
string->html
generate-link-text
-
diff --git a/collects/net/cgi-unit.rkt b/collects/net/cgi-unit.rkt
index 295836e..ac90c64 100644
--- a/collects/net/cgi-unit.rkt
+++ b/collects/net/cgi-unit.rkt
@@ -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
- [(#\<) "<"]
- [(#\>) ">"]
- [(#\&) "&"]
- [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"
- ""
- ""
- ""
- ""
- ,(sa "" title "")
- ""
- ""
- ,(sa "")
- ""
- ,@body-lines
- ""
- ""
- "")])
- (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) ->
-(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)
- `(""
- ,@(map (lambda (bind)
- (string-append (symbol->string (car bind))
- " --> "
- (cdr bind)
- "
"))
- bindings)
- ""))
-
-;; 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':
" 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:
"
- 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 "" anchor-text ""))
+(provide cgi@)
diff --git a/collects/net/dns-unit.rkt b/collects/net/dns-unit.rkt
index 9c0d175..f5f99fb 100644
--- a/collects/net/dns-unit.rkt
+++ b/collects/net/dns-unit.rkt
@@ -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@)
diff --git a/collects/net/ftp-unit.rkt b/collects/net/ftp-unit.rkt
index 77436f8..42432a5 100644
--- a/collects/net/ftp-unit.rkt
+++ b/collects/net/ftp-unit.rkt
@@ -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@)
diff --git a/collects/net/head-unit.rkt b/collects/net/head-unit.rkt
index 8f18233..1a1606b 100644
--- a/collects/net/head-unit.rkt
+++ b/collects/net/head-unit.rkt
@@ -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@)
diff --git a/collects/net/imap-unit.rkt b/collects/net/imap-unit.rkt
index b9a7b83..4b28b4f 100644
--- a/collects/net/imap-unit.rkt
+++ b/collects/net/imap-unit.rkt
@@ -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@)
diff --git a/collects/net/mime-unit.rkt b/collects/net/mime-unit.rkt
index fee2e9f..538eab9 100644
--- a/collects/net/mime-unit.rkt
+++ b/collects/net/mime-unit.rkt
@@ -1,734 +1,8 @@
-;;;
-;;; ---- 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
-;;
-;;
-;; 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 :=
-;;
-(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 :=
-(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 :=
-(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 :=
-(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*
-;; 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@)
diff --git a/collects/net/nntp-unit.rkt b/collects/net/nntp-unit.rkt
index 408f0a9..0650418 100644
--- a/collects/net/nntp-unit.rkt
+++ b/collects/net/nntp-unit.rkt
@@ -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@)
diff --git a/collects/net/pop3-unit.rkt b/collects/net/pop3-unit.rkt
index 204a0c0..5c5cc7c 100644
--- a/collects/net/pop3-unit.rkt
+++ b/collects/net/pop3-unit.rkt
@@ -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@)
diff --git a/collects/net/qp-unit.rkt b/collects/net/qp-unit.rkt
index 8cbc457..1d7f2eb 100644
--- a/collects/net/qp-unit.rkt
+++ b/collects/net/qp-unit.rkt
@@ -1,165 +1,8 @@
-;;;
-;;; ---- 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
-;;
-;;
-;; 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@)
diff --git a/collects/net/sendmail-unit.rkt b/collects/net/sendmail-unit.rkt
index bca94df..2fd9706 100644
--- a/collects/net/sendmail-unit.rkt
+++ b/collects/net/sendmail-unit.rkt
@@ -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@)
diff --git a/collects/net/smtp-unit.rkt b/collects/net/smtp-unit.rkt
index fae6c4b..98adc51 100644
--- a/collects/net/smtp-unit.rkt
+++ b/collects/net/smtp-unit.rkt
@@ -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@)
diff --git a/collects/net/uri-codec-unit.rkt b/collects/net/uri-codec-unit.rkt
index 42a2ff3..f680d8a 100644
--- a/collects/net/uri-codec-unit.rkt
+++ b/collects/net/uri-codec-unit.rkt
@@ -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.
-
-|#
-
-
-;;;
-;;; ---- 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
-;;
-;;
-;; 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@)
diff --git a/collects/net/url-unit.rkt b/collects/net/url-unit.rkt
index a4b4acb..98fe4d3 100644
--- a/collects/net/url-unit.rkt
+++ b/collects/net/url-unit.rkt
@@ -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)
- ;; \\?\: 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@)
diff --git a/collects/racket/private/old-rp.rkt b/collects/racket/private/old-rp.rkt
index 74f1554..14b78db 100644
--- a/collects/racket/private/old-rp.rkt
+++ b/collects/racket/private/old-rp.rkt
@@ -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)