diff --git a/collects/net/cgi.rkt b/collects/net/cgi.rkt
index b848d16f0e..9612982942 100644
--- a/collects/net/cgi.rkt
+++ b/collects/net/cgi.rkt
@@ -1,6 +1,227 @@
#lang racket/base
-(require racket/unit "cgi-sig.rkt" "cgi-unit.rkt")
-(define-values/invoke-unit/infer cgi@)
+(require "uri-codec.rkt")
-(provide-signature-elements cgi^)
+(provide
+ ;; -- exceptions raised --
+ (struct-out cgi-error)
+ (struct-out incomplete-%-suffix)
+ (struct-out invalid-%-suffix)
+
+ ;; -- cgi methods --
+ get-bindings
+ get-bindings/post
+ get-bindings/get
+ output-http-headers
+ generate-html-output
+ generate-error-output
+ bindings-as-html
+ extract-bindings
+ extract-binding/single
+ get-cgi-method
+
+ ;; -- general HTML utilities --
+ string->html
+ generate-link-text)
+
+;; type bindings = list ((symbol . string))
+
+;; --------------------------------------------------------------------
+
+;; 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 ""))
diff --git a/collects/net/dns.rkt b/collects/net/dns.rkt
index 901649091f..6496204bb7 100644
--- a/collects/net/dns.rkt
+++ b/collects/net/dns.rkt
@@ -1,6 +1,341 @@
#lang racket/base
-(require racket/unit "dns-sig.rkt" "dns-unit.rkt")
-(define-values/invoke-unit/infer dns@)
+(require racket/udp
+ racket/system)
-(provide-signature-elements dns^)
+(provide dns-get-address
+ dns-get-name
+ dns-get-mail-exchanger
+ dns-find-nameserver)
+
+;; 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]))
diff --git a/collects/net/ftp.rkt b/collects/net/ftp.rkt
index 5e4ff2a349..6702448612 100644
--- a/collects/net/ftp.rkt
+++ b/collects/net/ftp.rkt
@@ -1,6 +1,215 @@
#lang racket/base
-(require racket/unit "ftp-sig.rkt" "ftp-unit.rkt")
-(define-values/invoke-unit/infer ftp@)
+(require racket/date racket/file racket/port racket/tcp)
-(provide-signature-elements ftp^)
+(provide ftp-connection?
+ ftp-cd
+ ftp-establish-connection ftp-establish-connection*
+ ftp-close-connection
+ ftp-directory-list
+ ftp-download-file
+ ftp-make-file-seconds)
+
+;; opqaue record to represent an FTP connection:
+(define-struct ftp-connection (in out))
+
+(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)))
diff --git a/collects/net/imap.rkt b/collects/net/imap.rkt
index 6c02a92485..37e8b00be7 100644
--- a/collects/net/imap.rkt
+++ b/collects/net/imap.rkt
@@ -1,7 +1,12 @@
#lang racket/base
-(require racket/unit racket/contract "imap-sig.rkt" "imap-unit.rkt")
-(define-values/invoke-unit/infer imap@)
+(require racket/contract/base racket/tcp "private/rbtree.rkt")
+
+;; define the imap struct and its predicate here, for use in the contract, below
+(define-struct imap (r w exists recent unseen uidnext uidvalidity
+ expunges fetches new?)
+ #:mutable)
+(define (imap-connection? v) (imap? v))
(provide/contract
[imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
@@ -48,3 +53,546 @@
imap-create-mailbox
imap-mailbox-flags)
+
+(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 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)))
diff --git a/collects/net/mime.rkt b/collects/net/mime.rkt
index 9714637433..508a656597 100644
--- a/collects/net/mime.rkt
+++ b/collects/net/mime.rkt
@@ -23,21 +23,725 @@
;;; Author: Francisco Solsona
;;
-;;
-;; Commentary:
+;; Commentary: MIME support for PLT Scheme: an implementation of
+;; rfc2045, rfc2046, rfc2047, rfc2048, and rfc2049.
#lang racket/base
-(require racket/unit
- "mime-sig.rkt" "mime-unit.rkt" "qp.rkt" "base64.rkt" "head.rkt")
-;(define-unit-from-context base64@ base64^)
-;(define-unit-from-context qp@ qp^)
-;(define-unit-from-context head@ head^)
+(require racket/port "mime-util.rkt" "qp.rkt" "base64.rkt" "head.rkt")
-(define-values/invoke-unit/infer
- (export mime^)
- (link mime@))
+(provide
+ ;; -- exceptions raised --
+ (struct-out mime-error)
+ (struct-out unexpected-termination)
+ (struct-out missing-multipart-boundary-parameter)
+ (struct-out malformed-multipart-entity)
+ (struct-out empty-mechanism)
+ (struct-out empty-type)
+ (struct-out empty-subtype)
+ (struct-out empty-disposition-type)
-(provide-signature-elements mime^)
+ ;; -- basic mime structures --
+ (struct-out message)
+ (struct-out entity)
+ (struct-out disposition)
-;;; mime.rkt ends here
+ ;; -- mime methods --
+ mime-analyze)
+
+;; 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)
diff --git a/collects/net/nntp.rkt b/collects/net/nntp.rkt
index 816aa5047d..da8ae8dfdb 100644
--- a/collects/net/nntp.rkt
+++ b/collects/net/nntp.rkt
@@ -1,6 +1,325 @@
#lang racket/base
-(require racket/unit "nntp-sig.rkt" "nntp-unit.rkt")
-(define-values/invoke-unit/infer nntp@)
+(require racket/tcp)
-(provide-signature-elements nntp^)
+(provide (struct-out communicator)
+ connect-to-server connect-to-server* disconnect-from-server
+ authenticate-user open-news-group
+ head-of-message body-of-message
+ newnews-since generic-message-command
+ make-desired-header extract-desired-headers
+
+ (struct-out nntp)
+ (struct-out unexpected-response)
+ (struct-out bad-status-line)
+ (struct-out premature-close)
+ (struct-out bad-newsgroup-line)
+ (struct-out non-existent-group)
+ (struct-out article-not-in-group)
+ (struct-out no-group-selected)
+ (struct-out article-not-found)
+ (struct-out authentication-rejected))
+
+;; 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))
diff --git a/collects/net/pop3.rkt b/collects/net/pop3.rkt
index 099a9fa14a..2142b8cd8d 100644
--- a/collects/net/pop3.rkt
+++ b/collects/net/pop3.rkt
@@ -1,13 +1,9 @@
#lang racket/base
-(require racket/unit "pop3-sig.rkt" "pop3-unit.rkt")
-(define-values/invoke-unit/infer pop3@)
-
-(provide-signature-elements pop3^)
+;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
#|
-
-> (require-library "pop3.rkt" "net")
+> (require net/pop3)
> (define c (connect-to-server "cs.rice.edu"))
> (authenticate/plain-text "scheme" "********" c)
> (get-mailbox-status c)
@@ -28,3 +24,408 @@
("some body" "text" "goes" "." "here" "." "")
> (disconnect-from-server c)
|#
+
+(require racket/tcp)
+
+(provide (struct-out communicator)
+ connect-to-server connect-to-server* disconnect-from-server
+ authenticate/plain-text
+ get-mailbox-status
+ get-message/complete get-message/headers get-message/body
+ delete-message
+ get-unique-id/single get-unique-id/all
+
+ make-desired-header extract-desired-headers
+
+ (struct-out pop3)
+ (struct-out cannot-connect)
+ (struct-out username-rejected)
+ (struct-out password-rejected)
+ (struct-out not-ready-for-transaction)
+ (struct-out not-given-headers)
+ (struct-out illegal-message-number)
+ (struct-out cannot-delete-message)
+ (struct-out disconnect-not-quiet)
+ (struct-out malformed-server-response))
+
+;; 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))))))
diff --git a/collects/net/qp.rkt b/collects/net/qp.rkt
index c5267fb6b1..7522a6c863 100644
--- a/collects/net/qp.rkt
+++ b/collects/net/qp.rkt
@@ -6,31 +6,166 @@
;;;
;;; This file is part of mime-plt.
-;;; mime-plt is free software; you can redistribute it and/or
+;;; qp 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.
-;;; mime-plt is distributed in the hope that it will be useful,
+;;; qp 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 mime-plt; if not, write to the Free Software
+;;; License along with qp; 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/base
-(require racket/unit "qp-sig.rkt" "qp-unit.rkt")
-(define-values/invoke-unit/infer qp@)
+(provide
+ ;; -- exceptions raised --
+ (struct-out qp-error)
+ (struct-out qp-wrong-input)
+ (struct-out qp-wrong-line-size)
-(provide-signature-elements qp^)
+ ;; -- qp methods --
+ qp-encode
+ qp-decode
+ qp-encode-stream
+ qp-decode-stream)
+
+;; 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.rkt ends here
diff --git a/collects/net/scribblings/base64.scrbl b/collects/net/scribblings/base64.scrbl
index 7d74db1fd6..0d3b6293ed 100644
--- a/collects/net/scribblings/base64.scrbl
+++ b/collects/net/scribblings/base64.scrbl
@@ -46,6 +46,10 @@ end-of-file or Base 64 terminator @litchar{=} from @racket[in].}
@section{Base64 Unit}
+@margin-note{@racket[base64@] and @racket[base64^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/base64] module.}
+
@defmodule[net/base64-unit]
@defthing[base64@ unit?]{
diff --git a/collects/net/scribblings/cgi.scrbl b/collects/net/scribblings/cgi.scrbl
index 562d659d92..169ccef9b0 100644
--- a/collects/net/scribblings/cgi.scrbl
+++ b/collects/net/scribblings/cgi.scrbl
@@ -140,6 +140,10 @@ query is invalid.}
@section{CGI Unit}
+@margin-note{@racket[cgi@] and @racket[cgi^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/cgi] module.}
+
@defmodule[net/cgi-unit]
@defthing[cgi@ unit?]{
diff --git a/collects/net/scribblings/dns.scrbl b/collects/net/scribblings/dns.scrbl
index 016a237413..552c59d202 100644
--- a/collects/net/scribblings/dns.scrbl
+++ b/collects/net/scribblings/dns.scrbl
@@ -56,6 +56,10 @@ extract the first nameserver address. On Windows, it runs
@section{DNS Unit}
+@margin-note{@racket[dns@] and @racket[dns^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/dns] module.}
+
@defmodule[net/dns-unit]
@defthing[dns@ unit?]{
diff --git a/collects/net/scribblings/ftp.scrbl b/collects/net/scribblings/ftp.scrbl
index 7c8fc253db..1bbcaf0387 100644
--- a/collects/net/scribblings/ftp.scrbl
+++ b/collects/net/scribblings/ftp.scrbl
@@ -88,6 +88,10 @@ file, then moved into place on success).}
@section{FTP Unit}
+@margin-note{@racket[ftp@] and @racket[ftp^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/ftp] module.}
+
@defmodule[net/ftp-unit]
@defthing[ftp@ unit?]{
diff --git a/collects/net/scribblings/head.scrbl b/collects/net/scribblings/head.scrbl
index d93cba84f0..440612e680 100644
--- a/collects/net/scribblings/head.scrbl
+++ b/collects/net/scribblings/head.scrbl
@@ -222,6 +222,10 @@ are comma-separated, and possibly broken into multiple lines.
@section{Header Unit}
+@margin-note{@racket[head@] and @racket[head^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/head] module.}
+
@defmodule[net/head-unit]
@defthing[head@ unit?]{
diff --git a/collects/net/scribblings/imap.scrbl b/collects/net/scribblings/imap.scrbl
index e4f835a4d5..da85e9565d 100644
--- a/collects/net/scribblings/imap.scrbl
+++ b/collects/net/scribblings/imap.scrbl
@@ -497,6 +497,10 @@ Returns a list of IMAP flags for the given mailbox. See also
@section{IMAP Unit}
+@margin-note{@racket[imap@] and @racket[imap^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/imap] module.}
+
@defmodule[net/imap-unit]
@defthing[imap@ unit?]{
diff --git a/collects/net/scribblings/mime.scrbl b/collects/net/scribblings/mime.scrbl
index 30b8c38026..f611e1e641 100644
--- a/collects/net/scribblings/mime.scrbl
+++ b/collects/net/scribblings/mime.scrbl
@@ -236,6 +236,10 @@ field, or when the specification is incorrectly formatted.}
@section{MIME Unit}
+@margin-note{@racket[mime@] and @racket[mime^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/mime] module.}
+
@defmodule[net/mime-unit]
@defthing[mime@ unit?]{
diff --git a/collects/net/scribblings/nntp.scrbl b/collects/net/scribblings/nntp.scrbl
index d63ceca3c2..dbace6999d 100644
--- a/collects/net/scribblings/nntp.scrbl
+++ b/collects/net/scribblings/nntp.scrbl
@@ -135,6 +135,10 @@ Raised when the server reject an authentication attempt.}
@section{NNTP Unit}
+@margin-note{@racket[nntp@] and @racket[nntp^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/nntp] module.}
+
@defmodule[net/nntp-unit]
@defthing[nntp@ unit?]{
diff --git a/collects/net/scribblings/pop3.scrbl b/collects/net/scribblings/pop3.scrbl
index 99b3669c32..9a78f86769 100644
--- a/collects/net/scribblings/pop3.scrbl
+++ b/collects/net/scribblings/pop3.scrbl
@@ -184,6 +184,10 @@ Raised when the server produces a malformed response.}
@section{POP3 Unit}
+@margin-note{@racket[pop3@] and @racket[pop3^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/pop3] module.}
+
@defmodule[net/pop3-unit]
@defthing[pop3@ unit?]{
diff --git a/collects/net/scribblings/qp.scrbl b/collects/net/scribblings/qp.scrbl
index c5f0a6d608..18ef49e957 100644
--- a/collects/net/scribblings/qp.scrbl
+++ b/collects/net/scribblings/qp.scrbl
@@ -66,6 +66,10 @@ backward compatibility.}
@section{Quoted-Printable Unit}
+@margin-note{@racket[qp@] and @racket[qp^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/qp] module.}
+
@defmodule[net/qp-unit]
@defthing[qp@ unit?]{
diff --git a/collects/net/scribblings/sendmail.scrbl b/collects/net/scribblings/sendmail.scrbl
index cef43caa42..d034f15662 100644
--- a/collects/net/scribblings/sendmail.scrbl
+++ b/collects/net/scribblings/sendmail.scrbl
@@ -63,6 +63,10 @@ Raised when no mail recipients were specified for
@section{Sendmail Unit}
+@margin-note{@racket[sendmail@] and @racket[sendmail^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/sendmail] module.}
+
@defmodule[net/sendmail-unit]
@defthing[sendmail@ unit?]{
diff --git a/collects/net/scribblings/smtp.scrbl b/collects/net/scribblings/smtp.scrbl
index 46cc382838..a6f768f300 100644
--- a/collects/net/scribblings/smtp.scrbl
+++ b/collects/net/scribblings/smtp.scrbl
@@ -102,6 +102,10 @@ probably will not).}
@section{SMTP Unit}
+@margin-note{@racket[smtp@] and @racket[smtp^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/smtp] module.}
+
@defmodule[net/smtp-unit]
@defthing[smtp@ unit?]{
diff --git a/collects/net/scribblings/uri-codec.scrbl b/collects/net/scribblings/uri-codec.scrbl
index 57f3c30ebc..17a8da688c 100644
--- a/collects/net/scribblings/uri-codec.scrbl
+++ b/collects/net/scribblings/uri-codec.scrbl
@@ -154,3 +154,27 @@ use/recognize only of the separators.
(form-urlencoded->alist "x=foo;y=bar;z=baz")
(alist->form-urlencoded ex)
]}
+
+@; ----------------------------------------
+
+@section{URI Codec Unit}
+
+@margin-note{@racket[uri-codec@] and @racket[uri-codec^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/uri-codec] module.}
+
+@defmodule[net/uri-codec-unit]
+
+@defthing[uri-codec@ unit?]{
+
+Imports nothing, exports @racket[uri-codec^].}
+
+@; ----------------------------------------
+
+@section{URI Codec Signature}
+
+@defmodule[net/uri-codec-sig]
+
+@defsignature[uri-codec^ ()]{}
+
+Includes everything exported by the @racketmodname[net/uri-codec] module.
diff --git a/collects/net/scribblings/url.scrbl b/collects/net/scribblings/url.scrbl
index ed8ca9b98b..e1b2db5f32 100644
--- a/collects/net/scribblings/url.scrbl
+++ b/collects/net/scribblings/url.scrbl
@@ -361,6 +361,10 @@ as described with @racket[get-pure-port].}
@section{URL Unit}
+@margin-note{@racket[url@], @racket[url^], and @racket[url+scheme^] are deprecated.
+They exist for backward-compatibility and will likely be removed in
+the future. New code should use the @racketmodname[net/url] module.}
+
@defmodule[net/url-unit]
@defthing[url@ unit?]{
diff --git a/collects/net/sendmail.rkt b/collects/net/sendmail.rkt
index e759519616..025aec0454 100644
--- a/collects/net/sendmail.rkt
+++ b/collects/net/sendmail.rkt
@@ -1,6 +1,120 @@
#lang racket/base
-(require racket/unit "sendmail-sig.rkt" "sendmail-unit.rkt")
-(define-values/invoke-unit/infer sendmail@)
+(require racket/system)
-(provide-signature-elements sendmail^)
+(provide send-mail-message/port
+ send-mail-message
+ (struct-out no-mail-recipients))
+
+(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)))
diff --git a/collects/net/smtp.rkt b/collects/net/smtp.rkt
index 4e213d4701..c635a4580b 100644
--- a/collects/net/smtp.rkt
+++ b/collects/net/smtp.rkt
@@ -1,6 +1,166 @@
#lang racket/base
-(require racket/unit "smtp-sig.rkt" "smtp-unit.rkt")
-(define-values/invoke-unit/infer smtp@)
+(require racket/tcp "base64.rkt")
-(provide-signature-elements smtp^)
+(provide smtp-sending-server
+ smtp-send-message
+ smtp-send-message*
+ smtp-sending-end-of-message)
+
+(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))))
diff --git a/collects/tests/net/url-port.rkt b/collects/tests/net/url-port.rkt
index 526542258d..d7e4cdda9e 100644
--- a/collects/tests/net/url-port.rkt
+++ b/collects/tests/net/url-port.rkt
@@ -47,6 +47,11 @@
=>
"This is the data in the first chunk and this is the second one"
+ (get-pure
+ "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n20\r\nThis is the data in the first ch\r\n21\r\nand this is the second oneXXXXXXX\r\n0\r\n")
+ =>
+ "This is the data in the first chand this is the second oneXXXXXXX"
+
(get-impure
"HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nTransfer-Encoding: chunked\r\n\r\n23\r\nThis is the data in the first chunk\r\n1A\r\nand this is the second one\r\n0\r\n")
=>