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

.

Browse Source 
original commit: ff0081f4b2e3bc1cdc474aa4b43762edbcd3816a
This commit is contained in:
Matthew Flatt 2001-05-07 17:04:08 +00:00
parent 84211b805d
commit ad85e9bd5e
10 changed files with 1537 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/net/cgi-sig.ss Normal file
View File

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

326
collects/net/cgi-unit.ss Normal file
View File

@ -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
((#\<) "&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
(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"
""
"<html>"
"<!-- The form was processed, and this document was generated,"
" using the CGI utilities for MzScheme. For more information"
" on MzScheme, see"
" http://www.cs.rice.edu/CS/PLT/packages/mzscheme/"
" and for the CGI utilities, contact Shriram Krishnamurthi"
" (shriram@cs.rice.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>")))))
;; 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) -> <exit>
(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)
`("<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
(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 <p>")
,@(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 <p>")
,@(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 "<a href=\"" url "\">" anchor-text "</a>")))
;; ====================================================================
)))

11
collects/net/dns-sig.ss Normal file
View File

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

301
collects/net/dns-unit.ss Normal file
View File

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

24
collects/net/nntp-sig.ss Normal file
View File

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

286
collects/net/nntp-unit.ss Normal file
View File

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

27
collects/net/pop3-sig.ss Normal file
View File

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

409
collects/net/pop3-unit.ss Normal file
View File

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

11
collects/net/sendmail-sig.ss Normal file
View File

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

112
collects/net/sendmail-unit.ss Normal file
View File

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