diff --git a/collects/net/cgi-sig.ss b/collects/net/cgi-sig.ss new file mode 100644 index 0000000..8b88696 --- /dev/null +++ b/collects/net/cgi-sig.ss @@ -0,0 +1,30 @@ + +(module cgi-sig mzscheme + (require (lib "unitsig.ss")) + + (provide net:cgi^) + + (define-signature net:cgi^ + ( + ;; -- exceptions raised -- + (struct cgi-error ()) + (struct incomplete-%-suffix (chars)) + (struct invalid-%-suffix (char)) + + ;; -- 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 + ))) + diff --git a/collects/net/cgi-unit.ss b/collects/net/cgi-unit.ss new file mode 100644 index 0000000..6771755 --- /dev/null +++ b/collects/net/cgi-unit.ss @@ -0,0 +1,326 @@ + +(module cgi-unit mzscheme + (require (lib "unitsig.ss") + (lib "etc.ss")) + + (require "cgi-sig.ss") + + (provide net:cgi@) + (define net:cgi@ + (unit/sig net:cgi^ + (import) + + ;; 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 struct:cgi-error) (chars)) + + ;; char : char + ;; -- an invalid character in a hex string + + (define-struct (invalid-%-suffix struct:cgi-error) (char)) + + ;; -------------------------------------------------------------------- + + ;; query-chars->string : + ;; list (char) -> string + + ;; -- The input is the characters 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-chars->string + (lambda (chars) + (list->string + (let loop ((chars chars)) + (if (null? chars) null + (let ((first (car chars)) + (rest (cdr chars))) + (let-values (((this rest) + (cond + ((char=? first #\+) + (values #\space rest)) + ((char=? first #\%) + (if (and (pair? rest) + (pair? (cdr rest))) + (values + (integer->char + (or (string->number + (string + (car rest) (cadr rest)) + 16) + (raise (make-invalid-%-suffix + (if (string->number + (string (car rest)) + 16) + (cadr rest) + (car rest)))))) + (cddr rest)) + (raise + (make-incomplete-%-suffix rest)))) + (else + (values first rest))))) + (cons this (loop rest))))))))) + + ;; string->html : + ;; string -> string + ;; -- the input is raw text, the output is HTML appropriately quoted + + (define string->html + (lambda (s) + (apply string-append + (map (lambda (c) + (case c + ((#\<) "<") + ((#\>) ">") + ((#\&) "&") + (else (string c)))) + (string->list s))))) + + (define default-text-color "#000000") + (define default-bg-color "#ffffff") + (define default-link-color "#cc2200") + (define default-vlink-color "#882200") + (define default-alink-color "#444444") + + ;; generate-html-output : + ;; html-string x list (html-string) x ... -> () + + (define generate-html-output + (opt-lambda (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-each + (lambda (l) + (display l) (newline)) + `("Content-type: text/html" + "" + "" + "" + + "" + ,(sa "" title "") + "" + "" + ,(sa "") + "" + ,@body-lines + "" + "" + ""))))) + + ;; output-http-headers : -> void + (define (output-http-headers) + (printf "Content-type: text/html~a~n~a~n" #\return #\return)) + + ;; read-until-char : + ;; iport x char -> list (char) x bool + ;; -- operates on the default input port; the second value indicates + ;; whether reading stopped because an EOF was hit (as opposed to the + ;; delimiter being seen); the delimiter is not part of the result + + (define read-until-char + (lambda (ip delimiter) + (let loop ((chars '())) + (let ((c (read-char ip))) + (cond + ((eof-object? c) + (values (reverse chars) #t)) + ((char=? c delimiter) + (values (reverse chars) #f)) + (else + (loop (cons c chars)))))))) + + ;; read-name+value : + ;; iport -> (symbol + bool) x (string + bool) x bool + + ;; -- If the first value is false, so is the second, and the third is + ;; true, indicating EOF was reached without any input seen. Otherwise, + ;; the first and second values contain strings and the third is either + ;; true or false depending on whether the EOF has been reached. The + ;; strings are processed to remove the CGI spec "escape"s. + + ;; This code is _slightly_ lax: it allows an input to end in `&'. 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. + ;; It would also introduce needless modality and reduce flexibility. + + (define read-name+value + (lambda (ip) + (let-values + (((name eof?) + (read-until-char ip #\=))) + (cond + ((and eof? (null? name)) + (values #f #f #t)) + (eof? + (generate-error-output + (list "Server generated malformed input for POST method:" + (string-append + "No binding for `" (list->string name) "' field.")))) + (else + (let-values (((value eof?) + (read-until-char ip #\&))) + (values (string->symbol (query-chars->string name)) + (query-chars->string value) + eof?))))))) + + ;; get-bindings/post : + ;; () -> bindings + + (define get-bindings/post + (lambda () + (let-values (((name value eof?) + (read-name+value + (current-input-port)))) + (cond + ((and eof? (not name)) + null) + ((and eof? name) + (list (cons name value))) + (else + (cons (cons name value) + (get-bindings/post))))))) + + ;; get-bindings/get : + ;; () -> bindings + + (define get-bindings/get + (lambda () + (let ((p (open-input-string + (getenv "QUERY_STRING")))) + (let loop () + (let-values (((name value eof?) + (read-name+value p))) + (cond + ((and eof? (not name)) + null) + ((and eof? name) + (list (cons name value))) + (else + (cons (cons name value) + (loop))))))))) + + ;; get-bindings : + ;; () -> bindings + + (define get-bindings + (lambda () + (if (string=? (get-cgi-method) "POST") + (get-bindings/post) + (get-bindings/get)))) + + ;; generate-error-output : + ;; list (html-string) -> + + (define generate-error-output + (lambda (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 + (lambda (bindings) + `("" + ,@(map + (lambda (bind) + (string-append + (symbol->string (car bind)) + " --> " + (cdr bind) + "
")) + bindings) + ""))) + + ;; extract-bindings : + ;; (string + symbol) x bindings -> list (string) + + ;; -- Extracts the bindings associated with a given name. The semantics + ;; of forms states that a CHECKBOX may use the same NAME field multiple + ;; times. Hence, a list of strings is returned. Note that the result + ;; may be the empty list. + + (define extract-bindings + (lambda (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 + (lambda (field-name bindings) + (let ((field-name (if (symbol? field-name) field-name + (string->symbol field-name)))) + (let ((result (extract-bindings field-name bindings))) + (cond + ((null? result) + (generate-error-output + `(,(string-append "No binding for field `" + (if (symbol? field-name) + (symbol->string field-name) + field-name) + "' in

") + ,@(bindings-as-html bindings)))) + ((null? (cdr result)) + (car result)) + (else + (generate-error-output + `(,(string-append "Multiple bindings for field `" + (if (symbol? field-name) + (symbol->string field-name) + field-name) + "' where only one was expected in

") + ,@(bindings-as-html bindings))))))))) + + ;; get-cgi-method : + ;; () -> string + ;; -- string is either GET or POST (though future extension is possible) + + (define get-cgi-method + (lambda () + (getenv "REQUEST_METHOD"))) + + ;; generate-link-text : + ;; string x html-string -> html-string + + (define generate-link-text + (lambda (url anchor-text) + (string-append "" anchor-text ""))) + + ;; ==================================================================== + + ))) + diff --git a/collects/net/dns-sig.ss b/collects/net/dns-sig.ss new file mode 100644 index 0000000..b4352fe --- /dev/null +++ b/collects/net/dns-sig.ss @@ -0,0 +1,11 @@ + +(module dns-sig mzscheme + (require (lib "unitsig.ss")) + + (provide net:dns^) + + (define-signature net:dns^ + (dns-get-address + dns-get-mail-exchanger + dns-find-nameserver))) + diff --git a/collects/net/dns-unit.ss b/collects/net/dns-unit.ss new file mode 100644 index 0000000..e58fbf6 --- /dev/null +++ b/collects/net/dns-unit.ss @@ -0,0 +1,301 @@ + +(module dns-unit mzscheme + (require (lib "unitsig.ss")) + + (require "dns-sig.ss") + + (provide net:dns@) + (define net:dns@ + (unit/sig net:dns^ + (import) + + (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 (integer->char (arithmetic-shift n -8)) + (integer->char (modulo n 256)))) + + (define (octet-pair->number a b) + (+ (arithmetic-shift (char->integer a) 8) + (char->integer b))) + + (define (octet-quad->number a b c d) + (+ (arithmetic-shift (char->integer a) 24) + (arithmetic-shift (char->integer b) 16) + (arithmetic-shift (char->integer c) 8) + (char->integer d))) + + (define (name->octets s) + (let ([do-one (lambda (s) + (cons + (integer->char (string-length s)) + (string->list s)))]) + (let loop ([s s]) + (let ([m (regexp-match "^([^.]*)[.](.*)" s)]) + (if m + (append + (do-one (cadr m)) + (loop (caddr m))) + (append + (do-one s) + (list #\nul))))))) + + (define (make-std-query-header id question-count) + (append + (number->octet-pair id) + (list #\001 #\nul) ; 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 (char->integer (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]) + (cond + [(zero? len) + (let-values ([(s start) (parse-name start reply)]) + (let ([s0 (list->string (reverse! accum))]) + (values (if s + (string-append s0 "." s) + s0) + start)))] + [else (loop (sub1 len) (cdr start) (cons (car start) accum))]))] + [else + ;; Compression offset + (let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) + (char->integer (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)]) + (let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))] + [start (cddr start)]) + (let ([ttl (octet-quad->number (car start) (cadr start) + (caddr start) (cadddr start))] + [start (cddddr start)]) + (let ([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)]) + (let ([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) addr type class)] + [reply + (let-values ([(r w) (tcp-connect nameserver 53)]) + (dynamic-wind + void + + (lambda () + (display (list->string (add-size-tag query)) w) + (flush-output w) + + (let ([a (read-char r)] + [b (read-char r)]) + (let ([len (octet-pair->number a b)]) + (let ([s (read-string len r)]) + (unless (= len (string-length s)) + (error 'dns-query "unexpected EOF from server")) + (string->list s))))) + + (lambda () + (close-input-port r) + (close-output-port w))))]) + + ; First two bytes must match sent message id: + (unless (and (char=? (car reply) (car query)) + (char=? (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 (char->integer 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 (char->integer v0))) + qds ans nss ars reply))))))) + + (define cache (make-hash-table)) + (define (dns-query/cache nameserver addr type class) + (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))]) + (let ([v (hash-table-get cache key (lambda () #f))]) + (if v + (apply values v) + (let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)]) + (hash-table-put! 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" + (char->integer (list-ref s 0)) + (char->integer (list-ref s 1)) + (char->integer (list-ref s 2)) + (char->integer (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 (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 ans)) + (let ([s (rr-data (car 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) (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 + (format "nameserver[ ~a]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" #\tab) + l)]) + (and m (cadr m)))) + (and (not (eof-object? l)) + (loop))))))))] + [else #f]))))) + diff --git a/collects/net/nntp-sig.ss b/collects/net/nntp-sig.ss new file mode 100644 index 0000000..1747c0b --- /dev/null +++ b/collects/net/nntp-sig.ss @@ -0,0 +1,24 @@ + +(module nntp-sig mzscheme + (require (lib "unitsig.ss")) + + (provide net:nntp^) + + (define-signature net:nntp^ + ((struct communicator (sender receiver server port)) + connect-to-server disconnect-from-server + open-news-group + head-of-message body-of-message + make-desired-header extract-desired-headers + + (struct nntp ()) + (struct unexpected-response (code text)) + (struct bad-status-line (line)) + (struct premature-close (communicator)) + (struct bad-newsgroup-line (line)) + (struct non-existent-group (group)) + (struct article-not-in-group (article)) + (struct no-group-selected ()) + (struct article-not-found (article))))) + + diff --git a/collects/net/nntp-unit.ss b/collects/net/nntp-unit.ss new file mode 100644 index 0000000..0bb25c2 --- /dev/null +++ b/collects/net/nntp-unit.ss @@ -0,0 +1,286 @@ + +(module nntp-unit mzscheme + (require (lib "unitsig.ss") + (lib "etc.ss")) + + (require "nntp-sig.ss") + + (provide net:nntp@) + (define net:nntp@ + (unit/sig net:nntp^ + (import) + + ;; 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 struct:exn) ()) + (define-struct (unexpected-response struct:nntp) (code text)) + (define-struct (bad-status-line struct:nntp) (line)) + (define-struct (premature-close struct:nntp) (communicator)) + (define-struct (bad-newsgroup-line struct:nntp) (line)) + (define-struct (non-existent-group struct:nntp) (group)) + (define-struct (article-not-in-group struct:nntp) (article)) + (define-struct (no-group-selected struct:nntp) ()) + (define-struct (article-not-found struct:nntp) (article)) + + ;; signal-error : + ;; (exn-args ... -> exn) x format-string x values ... -> + ;; exn-args -> () + + ;; - throws an exception + + (define signal-error + (lambda (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 : + ;; string [x number] -> commnicator + + (define connect-to-server + (opt-lambda (server-name (port-number default-nntpd-port-number)) + (let-values (((receiver sender) + (tcp-connect server-name port-number))) + (let ((communicator + (make-communicator sender receiver server-name port-number))) + (let-values (((code response) + (get-single-line-response communicator))) + (case code + ((200) + communicator) + (else + ((signal-error make-unexpected-response + "unexpected connection response: ~s ~s" + code response) + code response)))))))) + + ;; close-communicator : + ;; communicator -> () + + (define close-communicator + (lambda (communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator)))) + + ;; disconnect-from-server : + ;; communicator -> () + + (define disconnect-from-server + (lambda (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)))))) + + ;; send-to-server : + ;; communicator x format-string x list (values) -> () + + (define send-to-server + (lambda (communicator message-template . rest) + (apply fprintf (communicator-sender communicator) + (string-append message-template "~n") + rest))) + + ;; parse-status-line : + ;; string -> number x string + + (define parse-status-line + (let ((pattern (regexp "([0-9]+) (.*)"))) + (lambda (line) + (let ((match (cdr (or (regexp-match pattern 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 + (lambda (server->client-port) + (read-line server->client-port 'return-linefeed))) + + ;; get-single-line-response : + ;; communicator -> number x string + + (define get-single-line-response + (lambda (communicator) + (let ((receiver (communicator-receiver communicator))) + (let ((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 + (lambda (communicator) + (let ((receiver (communicator-receiver communicator))) + (let loop () + (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 ".") + '()) + ((string=? l "..") + (cons "." (loop))) + (else + (cons l (loop))))))))) + + ;; 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 + (lambda (communicator) + (let ((receiver (communicator-receiver communicator))) + (let ((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))))))) + + ;; 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 + (let ((pattern (regexp "([0-9]+) ([0-9]+) ([0-9]+)"))) + (lambda (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 pattern 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))))))) + + ;; head/body-of-message : + ;; string x number -> communicator x number -> list (string) + + (define head/body-of-message + (lambda (command ok-code) + (lambda (communicator message-number) + (send-to-server communicator (string-append command " ~a") + (number->string message-number)) + (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 number ~s not in group" message-number) + message-number)) + ((412) + ((signal-error make-no-group-selected + "no group selected"))) + ((430) + ((signal-error make-article-not-found + "no article number ~s found" message-number) + message-number)) + (else + ((signal-error make-unexpected-response + "unexpected message access response: ~s" code) + code response)))))))) + + ;; head-of-message : + ;; communicator x number -> list (string) + + (define head-of-message + (head/body-of-message "HEAD" 221)) + + ;; body-of-message : + ;; communicator x number -> list (string) + + (define body-of-message + (head/body-of-message "BODY" 222)) + + ;; make-desired-header : + ;; string -> desired + + (define make-desired-header + (lambda (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 + (lambda (headers desireds) + (let loop ((headers headers)) + (if (null? headers) null + (let ((first (car headers)) + (rest (cdr headers))) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) + (cons first (loop rest)) + (loop rest)))))))))) + diff --git a/collects/net/pop3-sig.ss b/collects/net/pop3-sig.ss new file mode 100644 index 0000000..c24d04f --- /dev/null +++ b/collects/net/pop3-sig.ss @@ -0,0 +1,27 @@ + +(module pop3-sig mzscheme + (require (lib "unitsig.ss")) + + (provide net:pop3^) + + (define-signature net:pop3^ + ((struct communicator (sender receiver server port state)) + 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 pop3 ()) + (struct cannot-connect ()) + (struct username-rejected ()) + (struct password-rejected ()) + (struct not-ready-for-transaction (communicator)) + (struct not-given-headers (communicator message)) + (struct illegal-message-number (communicator message)) + (struct cannot-delete-message (communicator message)) + (struct disconnect-not-quiet (communicator)) + (struct malformed-server-response (communicator))))) diff --git a/collects/net/pop3-unit.ss b/collects/net/pop3-unit.ss new file mode 100644 index 0000000..4505726 --- /dev/null +++ b/collects/net/pop3-unit.ss @@ -0,0 +1,409 @@ + +(module pop3-unit mzscheme + (require (lib "unitsig.ss") + (lib "etc.ss")) + + (require "pop3-sig.ss") + + (provide net:pop3@) + (define net:pop3@ + (unit/sig net:pop3^ + (import) + + ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose + + ;; sender : oport + ;; receiver : iport + ;; server : string + ;; port : number + ;; state : symbol = (disconnected, authorization, transaction) + + (define-struct communicator (sender receiver server port state)) + + (define-struct (pop3 struct:exn) ()) + (define-struct (cannot-connect struct:pop3) ()) + (define-struct (username-rejected struct:pop3) ()) + (define-struct (password-rejected struct:pop3) ()) + (define-struct (not-ready-for-transaction struct:pop3) (communicator)) + (define-struct (not-given-headers struct:pop3) (communicator message)) + (define-struct (illegal-message-number struct:pop3) (communicator message)) + (define-struct (cannot-delete-message struct:exn) (communicator message)) + (define-struct (disconnect-not-quiet struct:pop3) (communicator)) + (define-struct (malformed-server-response struct:pop3) (communicator)) + + ;; signal-error : + ;; (exn-args ... -> exn) x format-string x values ... -> + ;; exn-args -> () + + (define signal-error + (lambda (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 + (lambda (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 struct:server-responses) ()) + (define-struct (-err struct:server-responses) ()) + + (define +ok (make-+ok)) + (define -err (make--err)) + + ;; connect-to-server : + ;; string [x number] -> communicator + + (define connect-to-server + (opt-lambda (server-name (port-number default-pop-port-number)) + (let-values (((receiver sender) + (tcp-connect 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))))))))) + + ;; authenticate/plain-text : + ;; string x string x communicator -> () + + ;; -- if authentication succeeds, sets the communicator's state to + ;; transaction. + + (define authenticate/plain-text + (lambda (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 + (let ((stat-regexp (regexp "([0-9]+) ([0-9]+)"))) + (lambda (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 + stat-regexp #f))) + result)))))) + + ;; get-message/complete : + ;; communicator x number -> list (string) x list (string) + + (define get-message/complete + (lambda (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 + (lambda (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 + (lambda (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 + (lambda (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 + (lambda (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 (regexp "([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 + (lambda (communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator)))) + + ;; disconnect-from-server : + ;; communicator -> () + + (define disconnect-from-server + (lambda (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 + (lambda (communicator message-template . rest) + (apply fprintf (communicator-sender communicator) + (string-append message-template "~n") + rest))) + + ;; get-one-line-from-server : + ;; iport -> string + + (define get-one-line-from-server + (lambda (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 + (let ((+ok-regexp (regexp "^\\+OK (.*)")) + (-err-regexp (regexp "^\\-ERR (.*)"))) + (lambda (communicator) + (let ((receiver (communicator-receiver communicator))) + (let ((status-line (get-one-line-from-server receiver))) + (let ((r (regexp-match +ok-regexp status-line))) + (if r + (values +ok (cadr r)) + (let ((r (regexp-match -err-regexp status-line))) + (if r + (values -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 + (lambda (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 + (lambda (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 + (lambda (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 + (lambda (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 + (lambda (headers desireds) + (let loop ((headers headers)) + (if (null? headers) null + (let ((first (car headers)) + (rest (cdr headers))) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) + (cons first (loop rest)) + (loop rest)))))))))) + diff --git a/collects/net/sendmail-sig.ss b/collects/net/sendmail-sig.ss new file mode 100644 index 0000000..f3ce211 --- /dev/null +++ b/collects/net/sendmail-sig.ss @@ -0,0 +1,11 @@ + +(module sendmail-sig mzscheme + (require (lib "unitsig.ss")) + + (provide net:sendmail^) + + (define-signature net:sendmail^ + (send-mail-message/port + send-mail-message + (struct no-mail-recipients ())))) + diff --git a/collects/net/sendmail-unit.ss b/collects/net/sendmail-unit.ss new file mode 100644 index 0000000..922e576 --- /dev/null +++ b/collects/net/sendmail-unit.ss @@ -0,0 +1,112 @@ + +(module sendmail-unit mzscheme + (require (lib "unitsig.ss") + (lib "process.ss")) + + (require "sendmail-sig.ss") + + (provide net:sendmail@) + (define net:sendmail@ + (unit/sig net:sendmail^ + (import) + + (define-struct (no-mail-recipients struct:exn) ()) + + (define sendmail-search-path + '("/usr/lib" "/usr/sbin")) + + (define sendmail-program-file + (if (eq? (system-type) 'unix) + (let loop ((paths sendmail-search-path)) + (if (null? paths) + (raise (make-exn:misc: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:misc: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 + (lambda (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))) + (let ((len (string-length first))) + (if (>= (+ len indent) 80) + (begin + (fprintf writer "~n ~a, " first) + (loop (cdr to) (+ len header-space 2))) + (begin + (fprintf writer "~a, " first) + (loop (cdr to) + (+ len indent 2)))))))))))) + (write-recipient-header "To" to-recipients) + (write-recipient-header "CC" cc-recipients)) + (fprintf writer "Subject: ~a~n" subject) + (fprintf writer "X-Mailer: MzScheme: see www.cs.rice.edu/CS/PLT/~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 + (lambda (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)))))))