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

adjust the "Transfer-Encoding: chunked" code to re-use bytes more

Browse Source 
agressively

original commit: 1fa6129afc
This commit is contained in:
Robby Findler 2011-10-02 21:06:35 -05:00
commit 853e6d7827
25 changed files with 3272 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

227
collects/net/cgi.rkt
View File

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

341
collects/net/dns.rkt
View File

@ -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]))

215
collects/net/ftp.rkt
View File

@ -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)))

552
collects/net/imap.rkt
View File

@ -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)))

728
collects/net/mime.rkt
View File

@ -23,21 +23,725 @@
;;; Author: Francisco Solsona <solsona@acm.org>
;;
;;
;; 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 := <Any RFC 822 header field which
;; begins with the string
;; "Content-">
;;
(define (MIME-extension-field header entity)
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
[target (regexp-match reg header)])
(and target
(set-entity-other!
entity
(append (entity-other entity)
(list (cons (regexp-replace reg header "\\1")
(trim-spaces (regexp-replace reg header "\\2")))))))))
;; type := discrete-type / composite-type
(define (type value)
(if (not value)
(raise (make-empty-type))
(or (discrete-type value)
(composite-type value))))
;; disposition-type := "inline" / "attachment" / extension-token
(define (disp-type value)
(if (not value)
(raise (make-empty-disposition-type))
(let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
(if val (cdr val) (extension-token value)))))
;; discrete-type := "text" / "image" / "audio" / "video" /
;; "application" / extension-token
(define (discrete-type value)
(let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
(if val (cdr val) (extension-token value))))
;; composite-type := "message" / "multipart" / extension-token
(define (composite-type value)
(let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
(if val (cdr val) (extension-token value))))
;; extension-token := ietf-token / x-token
(define (extension-token value)
(or (ietf-token value)
(x-token value)))
;; ietf-token := <An extension token defined by a
;; standards-track RFC and registered
;; with IANA.>
(define (ietf-token value)
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
(and ans (cdr ans))))
;; Directly from RFC 1700:
;; Type Subtype Description Reference
;; ---- ------- ----------- ---------
;; text plain [RFC1521,NSB]
;; richtext [RFC1521,NSB]
;; tab-separated-values [Paul Lindner]
;;
;; multipart mixed [RFC1521,NSB]
;; alternative [RFC1521,NSB]
;; digest [RFC1521,NSB]
;; parallel [RFC1521,NSB]
;; appledouble [MacMime,Patrik Faltstrom]
;; header-set [Dave Crocker]
;;
;; message rfc822 [RFC1521,NSB]
;; partial [RFC1521,NSB]
;; external-body [RFC1521,NSB]
;; news [RFC 1036, Henry Spencer]
;;
;; application octet-stream [RFC1521,NSB]
;; postscript [RFC1521,NSB]
;; oda [RFC1521,NSB]
;; atomicmail [atomicmail,NSB]
;; andrew-inset [andrew-inset,NSB]
;; slate [slate,terry crowley]
;; wita [Wang Info Transfer,Larry Campbell]
;; dec-dx [Digital Doc Trans, Larry Campbell]
;; dca-rft [IBM Doc Content Arch, Larry Campbell]
;; activemessage [Ehud Shapiro]
;; rtf [Paul Lindner]
;; applefile [MacMime,Patrik Faltstrom]
;; mac-binhex40 [MacMime,Patrik Faltstrom]
;; news-message-id [RFC1036, Henry Spencer]
;; news-transmission [RFC1036, Henry Spencer]
;; wordperfect5.1 [Paul Lindner]
;; pdf [Paul Lindner]
;; zip [Paul Lindner]
;; macwriteii [Paul Lindner]
;; msword [Paul Lindner]
;; remote-printing [RFC1486,MTR]
;;
;; image jpeg [RFC1521,NSB]
;; gif [RFC1521,NSB]
;; ief Image Exchange Format [RFC1314]
;; tiff Tag Image File Format [MTR]
;;
;; audio basic [RFC1521,NSB]
;;
;; video mpeg [RFC1521,NSB]
;; quicktime [Paul Lindner]
;; x-token := <The two characters "X-" or "x-" followed, with
;; no intervening white space, by any token>
(define (x-token value)
(let* ([r #rx"^[xX]-(.*)"]
[h (trim-spaces value)]
[ans (regexp-match r h)])
(and ans
(token (regexp-replace r h "\\1"))
h)))
;; subtype := extension-token / iana-token
(define (subtype value)
(if (not value)
(raise (make-empty-subtype))
(or (extension-token value)
(iana-token value))))
;; iana-token := <A publicly-defined extension token. Tokens
;; of this form must be registered with IANA
;; as specified in RFC 2048.>
(define (iana-token value)
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
(and ans (cdr ans))))
;; parameter := attribute "=" value
(define re:parameter (regexp "([^=]+)=(.+)"))
(define (parameter par)
(let* ([r re:parameter]
[att (attribute (regexp-replace r par "\\1"))]
[val (value (regexp-replace r par "\\2"))])
(if (regexp-match r par)
(cons (if att (lowercase att) "???") val)
(cons "???" par))))
;; value := token / quoted-string
(define (value val)
(or (token val)
(quoted-string val)
val))
;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
;; or tspecials>
;; tspecials := "(" / ")" / "<" / ">" / "@" /
;; "," / ";" / ":" / "\" / <">
;; "/" / "[" / "]" / "?" / "="
;; ; Must be in quoted-string,
;; ; to use within parameter values
(define (token value)
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
[ans (regexp-match tspecials value)])
(and ans
(string=? value (car ans))
(car ans))))
;; attribute := token
;; ; Matching of attributes
;; ; is ALWAYS case-insensitive.
(define attribute token)
(define re:quotes (regexp "\"(.+)\""))
(define (quoted-string str)
(let* ([quotes re:quotes]
[ans (regexp-match quotes str)])
(and ans (regexp-replace quotes str "\\1"))))
;; disposition-parm := filename-parm
;; / creation-date-parm
;; / modification-date-parm
;; / read-date-parm
;; / size-parm
;; / parameter
;;
;; filename-parm := "filename" "=" value
;;
;; creation-date-parm := "creation-date" "=" quoted-date-time
;;
;; modification-date-parm := "modification-date" "=" quoted-date-time
;;
;; read-date-parm := "read-date" "=" quoted-date-time
;;
;; size-parm := "size" "=" 1*DIGIT
(define (disp-params lst disp)
(let loop ([lst lst])
(unless (null? lst)
(let* ([p (parameter (trim-all-spaces (car lst)))]
[parm (car p)]
[value (cdr p)])
(cond [(string=? parm "filename")
(set-disposition-filename! disp value)]
[(string=? parm "creation-date")
(set-disposition-creation!
disp
(disp-quoted-data-time value))]
[(string=? parm "modification-date")
(set-disposition-modification!
disp
(disp-quoted-data-time value))]
[(string=? parm "read-date")
(set-disposition-read!
disp
(disp-quoted-data-time value))]
[(string=? parm "size")
(set-disposition-size!
disp
(string->number value))]
[else
(set-disposition-params!
disp
(append (disposition-params disp) (list p)))])
(loop (cdr lst))))))
;; date-time = [ day "," ] date time ; dd mm yy
;; ; hh:mm:ss zzz
;;
;; day = "Mon" / "Tue" / "Wed" / "Thu"
;; / "Fri" / "Sat" / "Sun"
;;
;; date = 1*2DIGIT month 2DIGIT ; day month year
;; ; e.g. 20 Jun 82
;;
;; month = "Jan" / "Feb" / "Mar" / "Apr"
;; / "May" / "Jun" / "Jul" / "Aug"
;; / "Sep" / "Oct" / "Nov" / "Dec"
;;
;; time = hour zone ; ANSI and Military
;;
;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT]
;; ; 00:00:00 - 23:59:59
;;
;; zone = "UT" / "GMT" ; Universal Time
;; ; North American : UT
;; / "EST" / "EDT" ; Eastern: - 5/ - 4
;; / "CST" / "CDT" ; Central: - 6/ - 5
;; / "MST" / "MDT" ; Mountain: - 7/ - 6
;; / "PST" / "PDT" ; Pacific: - 8/ - 7
;; / 1ALPHA ; Military: Z = UT;
;; ; A:-1; (J not used)
;; ; M:-12; N:+1; Y:+12
;; / ( ("+" / "-") 4DIGIT ) ; Local differential
;; ; hours+min. (HHMM)
(define date-time
(lambda (str)
;; Fix Me: I have to return a date structure, or time in seconds.
str))
;; quoted-date-time := quoted-string
;; ; contents MUST be an RFC 822 `date-time'
;; ; numeric timezones (+HHMM or -HHMM) MUST be used
(define disp-quoted-data-time date-time)

325
collects/net/nntp.rkt
View File

@ -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))

413
collects/net/pop3.rkt
View File

@ -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))))))

149
collects/net/qp.rkt
View File

@ -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 <solsona@acm.org>
;;
;;
;; 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

4
collects/net/scribblings/base64.scrbl
View File

@ -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?]{

4
collects/net/scribblings/cgi.scrbl
View File

@ -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?]{

4
collects/net/scribblings/dns.scrbl
View File

@ -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?]{

4
collects/net/scribblings/ftp.scrbl
View File

@ -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?]{

4
collects/net/scribblings/head.scrbl
View File

@ -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?]{

4
collects/net/scribblings/imap.scrbl
View File

@ -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?]{

4
collects/net/scribblings/mime.scrbl
View File

@ -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?]{

4
collects/net/scribblings/nntp.scrbl
View File

@ -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?]{

4
collects/net/scribblings/pop3.scrbl
View File

@ -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?]{

4
collects/net/scribblings/qp.scrbl
View File

@ -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?]{

4
collects/net/scribblings/sendmail.scrbl
View File

@ -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?]{

4
collects/net/scribblings/smtp.scrbl
View File

@ -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?]{

24
collects/net/scribblings/uri-codec.scrbl
View File

@ -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.

4
collects/net/scribblings/url.scrbl
View File

@ -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?]{

120
collects/net/sendmail.rkt
View File

@ -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)))

166
collects/net/smtp.rkt
View File

@ -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))))

5
collects/tests/net/url-port.rkt
View File

@ -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")
=>