diff --git a/cgi-script.scm b/cgi-script.scm deleted file mode 100644 index 0e519fc..0000000 --- a/cgi-script.scm +++ /dev/null @@ -1,95 +0,0 @@ -;;; NCSA's WWW Common Gateway Interface -- script-side code -*- Scheme -*- -;;; Copyright (c) 1995 by Olin Shivers. - -;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec". - -;;; Imports and non-R4RS'isms -;;; switch (control structure) -;;; getenv read-string (scsh) -;;; error -;;; parse-html-form-query (parse-html-forms package) - - -;;; This file provides routines to help you write programs in Scheme -;;; that can interface to HTTP servers using the CGI program interface -;;; to carry out HTTP transactions. - -;;; Other files/packages that will be of help: -;;; rfc822 For reading headers from entities. -;;; uri url For parsing and unparsing these things. Also for generally -;;; URI-decoding strings. -;;; htmlout For generating HTML output. - -;;; About HTML forms -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; This info is in fact independent of CGI, but important to know about, -;;; as many CGI scripts are written for responding to forms-entry in -;;; HTML browsers. -;;; -;;; The form's field data are turned into a single string, of the form -;;; name=val&name=val -;;; where the and parts are URI encoded to hide their -;;; &, =, and + chars, among other things. After URI encoding, the -;;; space chars are converted to + chars, just for fun. It is important -;;; to encode the spaces this way, because the perfectly general %xx escape -;;; mechanism might be insufficiently confusing. This variant encoding is -;;; called "form-url encoding." -;;; -;;; If the form's method is POST, -;;; Browser sends the form's field data in the entity block, e.g., -;;; "button=on&ans=yes". The request's Content-type: is application/ -;;; x-www-form-urlencoded, and the request's Content-length: is the -;;; number of bytes in the form data. -;;; -;;; If the form's method is GET, -;;; Browser sends the form's field data in the URL's part. -;;; (So the server will pass to the CGI script as $QUERY_STRING, -;;; and perhaps also on in argv[]). -;;; -;;; In either case, the data is "form-url encoded" (as described above). - -;;; ISINDEX queries: -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; (Likewise for ISINDEX URL queries from browsers.) -;;; Browser url-form encodes the query (see above), which then becomes the -;;; ? part of the URI. (Hence the CGI script will split the individual -;;; fields into argv[].) - - -;;; CGI interface: -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; - The URL's part is assigned to env var $QUERY_STRING, undecoded. -;;; - If it contains no raw "=" chars, it is split at "+" chars. The -;;; substrings are URI decoded, and become the elts of argv[]. You aren't -;;; supposed to rely on this unless you are replying to ISINDEX queries. -;;; - The CGI script is run with stdin hooked up to the socket. If it's going -;;; to read the entity, it should read $CONTENT_LENGTH bytes worth. -;;; - A bunch of env vars are set with useful values. -;;; - Entity block is passed to script on stdin; -;;; script writes reply to stdout. -;;; - If the script begins with "nph-" its output is the entire reply. -;;; Otherwise, when it replies to the server, it sends back a special -;;; little header that tells the server how to construct the real header -;;; for the reply. -;;; See the "spec" for further details. (URL above) - - -;;; (cgi-form-query) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Return the form data as an alist of decoded strings. -;;; So a query string like "button=on&reply=Oh,%20yes" becomes alist -;;; (("button" . "on") ("reply" . "Oh, yes")) -;;; This only works for GET and POST methods. - -(define (cgi-form-query) - (let ((request-method (getenv "REQUEST_METHOD"))) - (cond - - ((string=? request-method "GET") - (parse-html-form-query (getenv "QUERY_STRING"))) - - ((string=? request-method "POST") - (let ((nchars (string->number (getenv "CONTENT_LENGTH")))) - (parse-html-form-query (read-string nchars)))) - - (else (error "Method not handled."))))) ; Don't be calling me. diff --git a/crlf-io.scm b/crlf-io.scm deleted file mode 100644 index f2d4445..0000000 --- a/crlf-io.scm +++ /dev/null @@ -1,53 +0,0 @@ -;;; Read cr/lf and lf terminated lines. -*- Scheme -*- -;;; Copyright (c) 1995 by Olin Shivers. - -;;; External dependencies and non-R4RS'isms -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ascii->char (To create a carriage-return) -;;; read-line write-string force-output (scsh I/O procs) -;;; receive values (MV return) -;;; let-optionals -;;; "\r\n" in strings for cr/lf. (Not R4RS) - -;;; (read-crlf-line [fd/port retain-crlf?]) -> string or EOF object -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Read a line terminated by either line-feed or EOF. If RETAIN-CRLF? is #f -;;; (the default), a terminating cr/lf or lf sequence is trimmed from the -;;; returned string. -;;; -;;; This is simple and inefficient. It would be save one copy if we didn't -;;; use READ-LINE, but replicated its implementation instead. - -(define (read-crlf-line . args) - (let-optionals args ((fd/port (current-input-port)) - (retain-crlf? #f)) - (let ((ln (read-line fd/port retain-crlf?))) - (if (or retain-crlf? (eof-object? ln)) - ln - (let ((slen (string-length ln))) ; Trim a trailing cr, if any. - (if (or (zero? slen) - (not (char=? (string-ref ln (- slen 1)) cr))) - ln - (substring ln 0 (- slen 1)))))))) - -(define cr (ascii->char 13)) - -(define (write-crlf port) - (write-string "\r\n" port) - (force-output port)) - -(define (read-crlf-line-timeout . args) - (let-optionals args ((fd/port (current-input-port)) - (retain-crlf? #f) - (timeout 8000) - (max-interval 500)) - (let loop ((waited 0) (interval 100)) - (cond ((> waited timeout) - 'timeout) - ((char-ready? fd/port) - (read-crlf-line fd/port retain-crlf?)) - (else (sleep interval) - (loop (+ waited interval) (min (* interval 2) - max-interval))))))) - - diff --git a/dns.scm b/dns.scm deleted file mode 100644 index aad89c7..0000000 --- a/dns.scm +++ /dev/null @@ -1,1221 +0,0 @@ -; -; dns.scm -; -; Implementation of the RFC1035 -; domain names - implementation and specification -; based on the PLT-implementation. -; -; -; TODO: -; - test, test, test -; - types from newer RFCs (41, unknown) -; - more documentation -; -; -; sample usage: -; -; (dns-lookup-name [nameserver]) --> -; (dns-lookup-ip [nameserver]) --> -; (dns-lookup-nameserver [nameserver]) --> -; (dns-lookup-mail-exchanger [nameserver]) --> -; -; (dns-lookup [nameserver]) --> -; (show-dns-message the whole message, human readable -; -; (concurrent-lookup ) -; -; some lookups return a hostname (e.g. mx). -; many applications need instead of a hostname a ip address. -; force-ip and force-ip-list guarantee that a ip address is -; returned. -; -; (force-ip ) --> -; (force-ip-list ) --> - - - -;;; should debug-msgs be printed out? -(define *debug* #f) - - -;; --- error conditions -(define-condition-type 'invalid-type '()) -(define invalid-type? (condition-predicate 'invalid-type)) - -(define-condition-type 'invalid-class '()) -(define invalid-class? (condition-predicate 'invalid-class)) - -(define-condition-type 'parse-error '()) -(define parse-error? (condition-predicate 'parse)) - -(define-condition-type 'unexpected-eof-from-server '()) -(define unexpected-eof-from-server? (condition-predicate 'unexpected-eof-from-server)) - -(define-condition-type 'bad-address '()) -(define bad-address? (condition-predicate 'bad-address)) - -(define-condition-type 'no-nameservers '()) -(define no-nameservers? (condition-predicate 'no-nameservers)) - -(define-condition-type 'not-a-hostname '()) -(define not-a-hostname? (condition-predicate 'not-a-hostname)) - -(define-condition-type 'not-a-ip '()) -(define not-a-ip? (condition-predicate 'not-a-ip)) - - -(define-condition-type 'dns-format-error '()) -(define dns-format-error? (condition-predicate 'dns-format-error)) - -(define-condition-type 'dns-server-failure '()) -(define dns-server-failure? (condition-predicate 'dns-server-failure)) - -(define-condition-type 'dns-name-error '()) -(define dns-name-error? (condition-predicate 'dns-name-error)) - -(define-condition-type 'dns-not-implemented '()) -(define dns-not-implemented? (condition-predicate 'dns-not-implemented)) - -(define-condition-type 'dns-refused '()) -(define dns-refused? (condition-predicate 'dns-refused)) - - -(define-condition-type 'dns-error '(dns-format-error - dns-server-failure - dns-name-error - dns-not-implemented - dns-refused)) - -(define dns-error? (condition-predicate 'dns-error)) - - -;; called by the error-handlers, prints out error descriptions -(define (dns-error-messages condition more) - (cond - ((invalid-type? condition) - (display "make-octet-question: invalid DNS query type\n")) - ((invalid-class? condition) - (display "make-octet-question: invalid DNS query class\n")) - ((parse-error? condition) - (display "parse: error parsing server message\n")) - ((unexpected-eof-from-server? condition) - (display "send-receive-message: unexpected EOF from server\n")) - ((bad-address? condition) - (display "dns-get-information: bad address (in combination with query type)\n")) - ((no-nameservers? condition) - (display "dns-find-nameserver: no nameservers found in /etc/resolv.conf\n")) - ((not-a-hostname? condition) - (display "no hostname given\n")) - ((not-a-ip? condition) - (display "no ip given\n")) - ((dns-format-error? condition) - (display "error from server: (1) format error\n")) - ((dns-server-failure? condition) - (display "error from server: (2) server failure\n")) - ((dns-name-error? condition) - (display "error from server: (3) name error\n")) - ((dns-not-implemented? condition) - (display "error from server: (4) not implemented\n")) - ((dns-refused? condition) - (display "error from server: (5) refused\n")) - (else (more)))) - - - -;;; -- globals and types - -;; off -(define *nul* (ascii->char 0)) - -;; on -(define *on* (ascii->char 1)) - -;; message types -(define types - '((unknown 0); types, which are not yet implemented - (a 1) ; a host address - (ns 2) ; an authoritative name server - (md 3) ; (obsolete) - (mf 4) ; (obsolete) - (cname 5) ; the canonical name for an alias - (soa 6) ; marks the start of a zone of authority - (mb 7) ; (experimental) - (mg 8) ; (experimental) - (mr 9) ; (experimental) - (null 10) ; (experimental) - (wks 11) ; a well known service description - (ptr 12) ; a domain name pointer - (hinfo 13) ; host information - (minfo 14) ; (experimental) - (mx 15) ; mail exchange - (txt 16))) ; text strings - -;; message classes -(define classes - '((in 1) ; the Internet - (cs 2) ; (obsolete) - (ch 3) ; the CHAOS class - (hs 4))) ; Hesoid - - -;;; -- useful stuff - -;; assoc the other way round -(define (cossa i l) - (if *debug* (display "cossa\n")) - (cond - ((null? l) 'unknown) - ((equal? (cadar l) i) - (car l)) - (else (cossa i (cdr l))))) - -;; encodes numbers (16bit) to octets -(define (number->octet-pair n) - (if *debug* (display "number->octet-pair\n")) - (list (ascii->char (arithmetic-shift n -8)) - (ascii->char (modulo n 256)))) - -;; decodes octets to numbers (16bit) -(define (octet-pair->number a b) - (if *debug* (display "octet-pair->number\n")) - (+ (arithmetic-shift (char->ascii a) 8) - (char->ascii b))) - -;; encodes numbers (32bit) to octets, needed for ttl -(define (number->octet-quad n) - (if *debug* (display "number->octet-quad\n")) - (list (ascii->char (arithmetic-shift n -24)) - (ascii->char (modulo (arithmetic-shift n -16) 256)) - (ascii->char (modulo (arithmetic-shift n -8) 256)) - (ascii->char (modulo n 256)))) - -;; decodes octets to numbers, needed for 32bit ttl -(define (octet-quad->number a b c d) - (if *debug* (display "octet-quad->number\n")) - (+ (arithmetic-shift (char->ascii a) 24) - (arithmetic-shift (char->ascii b) 16) - (arithmetic-shift (char->ascii c) 8) - (char->ascii d))) - -;; encodes a domain-name string to octets -(define (name->octets s) - (define (encode-portion s) - (cons - (ascii->char (string-length s)) - (string->list s))) - - (if *debug* (display "name->octets\n")) - (let loop ((s s)) - (cond - ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) - => (lambda (match) - (append - (encode-portion (match:substring match 1)) - (loop (match:substring match 2))))) - (else - (if (= 0 (string-length s)) - (list *nul*) - (append - (encode-portion s) - (list *nul*))))))) - -;; for tcp: message has to be tagged with its length -(define (add-size-tag m) - (if *debug* (display "add-size-tag\n")) - (append (number->octet-pair (length m)) m)) - -;; converts an octeted-ip to an human readable ip-string -(define (ip->string s) - (if *debug* (display "ip->string\n")) - (format #f - "~a.~a.~a.~a" - (char->ascii (list-ref s 0)) - (char->ascii (list-ref s 1)) - (char->ascii (list-ref s 2)) - (char->ascii (list-ref s 3)))) - -;; converts an ip-string to octets -(define (string->ip s) - (if *debug* (display "string->ip\n")) - (let loop ((s s) - (result '())) - (cond - ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) - => (lambda (match) - (loop (match:substring match 2) (append result (list (ascii->char (string->number (match:substring match 1)))))))) - (else - (append result (list (ascii->char (string->number s)))))))) - -;; calculates a "random" number, needed for message-ids -(define random - (let ((crank (make-random (modulo (time) (- (expt 2 27) 1))))) - (lambda (limit) - (quotient (* (modulo (crank) 314159265) - limit) - 314159265)))) - -;; checks if a string is a ip -(define (ip? s) - (if *debug* (display "ip-string->in-addr\n")) - (let loop ((s s) - (count 0)) - (cond - ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) - => (lambda (match) - (let* ((portion (match:substring match 1)) - (number (string->number portion))) - (if (and number (< number 256)) - (loop (match:substring match 2) (+ count 1)) - #f)))) - (else - (let ((number (string->number s))) - (and number - (< number 256) - (= count 3) - #t)))))) - - -;; returns a in-addr.arpa name-string or #f (needed to resolve hostname by ip) -(define (ip-string->in-addr s) - (if *debug* (display "ip-string->in-addr\n")) - (let loop ((s s) - (count 0) - (result "")) - (cond - ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) - => (lambda (match) - (let* ((portion (match:substring match 1)) - (number (string->number portion))) - (if (and number (< number 256)) - (loop (match:substring match 2) (+ count 1) (string-append portion "." result)) - #f)))) - (else - (let ((number (string->number s))) - (and number - (< number 256) - (= count 3) - (string-append s "." result "in-addr.arpa"))))))) - -;; filters types in a list of rrs -(define (filter-type list type) - (if *debug* (display "ip-string->in-addr\n")) - (filter (lambda (rr) - (eq? (rr:type rr) type)) - list)) - -;; sorts a mx-rr-list by preference. needed for dns-lookup-mail-exchanger. -(define (sort-by-preference mx-list) - (sort-list mx-list - (lambda (a b) - (< (rr-data-mx:preference (rr:data a)) (rr-data-mx:preference (rr:data b)))))) - - -;; returns a IP if available (additonal type-a processing) -(define (force-ip name) - (let loop ((result (dns-lookup-name name))) - (if (ip? result) - result - (loop (dns-lookup-name result))))) - -;; returns a list of IPs (additional type-a processing) -(define (force-ip-list names) - (map (lambda (elem) (force-ip elem)) names)) - - -;;; -- message constructors: encode to octet-messages - -;; makes an message header -(define (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount) - (if *debug* (display "make-octet-header\n")) - (let* ((header-id (number->octet-pair id)) - (header-flags (list - (ascii->char (+ (arithmetic-shift qr 7) - (arithmetic-shift opcode 3) - (arithmetic-shift aa 2) - (arithmetic-shift tc 1) - rd)) - (ascii->char (+ (arithmetic-shift ra 7) - (arithmetic-shift z 4) - rcode)))) - (header-qdcount (number->octet-pair qdcount)) - (header-ancount (number->octet-pair ancount)) - (header-nscount (number->octet-pair nscount)) - (header-arcount (number->octet-pair arcount))) - (append header-id - header-flags - header-qdcount - header-ancount - header-nscount - header-arcount))) - - -;; a standard query header, usefull for most queries -(define (make-std-octet-query-header id question-count) - (if *debug* (display "make-std-octet-query-header\n")) - (let* ((qr 0) ; querytype: query 0, response 1 - (opcode 0) ; opcode: query 0, iquery 1 (OBSOLETE), status 2 - (aa 0) ; authorative answer (in answers only) - (tc 0) ; truncation (size matters only with UDP) - (rd 1) ; recursion desired: nameserver pursues the query recursivly (optional) - (ra 0) ; recursion available (in answers only) - (z 0) ; future use - (rcode 0) ; response code: error conditions (in answers only) - (qdcount question-count) - (ancount 0) ; answer count (in answers only) - (nscount 0) ; name server resources (in answers only) - (arcount 0)) ; additional records (in answers only) - - (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount))) - - -;; makes a question (name, type, class) -(define (make-octet-question name type class) - (if *debug* (display "make-octet-question\n")) - (if (not (assoc type types)) - (signal 'invalid-type)) - (if (not (assoc class classes)) - (signal 'invalid-class)) - - (let* ((qname (name->octets name)) - (qtype (number->octet-pair (cadr (assoc type types)))) - (qclass (number->octet-pair (cadr (assoc class classes))))) - (append qname qtype qclass))) - - -;; makes a query-message (header and question only) -(define (make-octet-query-message id name type class) - (if *debug* (display "make-octet-query-message\n")) - (append - (make-std-octet-query-header id 1) - (make-octet-question name type class))) - - -;; makes a resource record for ans, nss, ars (name, type, class, ttl, data) -(define (make-octet-rr name type class ttl rdata) - (if *debug* (display "make-octet-rr\n")) - (let* ((name (name->octets name)) - (type (number->octet-pair (cadr (assoc type types)))) - (class (number->octet-pair (cadr (assoc class classes)))) - (ttl (number->octet-quad ttl)) - (rdlength (number->octet-pair (length rdata))) - (rdata rdata)) - (append name type class ttl rdlength rdata))) - - - -;;; -- parsed message records - -;;; -- dns-message: complete data-structure of an dns-lookup -(define-record dns-message - query - reply - cache? - protocol - tried-nameservers) - -;; message -(define-record message - header - questions - answers - nameservers - additionals - source) - -;; header -(define-record header - id - flags - qdc - anc - nsc - arc) - -;; flags -(define-record flags - querytype - opcode - auth - trunc - recursiondesired - recursionavailable - z - rcode) - -;; question -(define-record question - name - type - class) - -;; rr -(define-record rr - name - type - class - ttl - data) - -;; cache -(define-record cache - answer - ttl - time) - -;;; -- message parser - -;; parses a domain-name in an message. returns the name and the rest of the message. -(define (parse-name start message) - (if *debug* (display "parse-name\n")) - (let ((v (char->ascii (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 '())) - (cond - ((zero? len) - (call-with-values - (lambda () (parse-name start message)) - (lambda (s start) - (let ((s0 (list->string (reverse! accum)))) - (values (if s - (string-append s0 "." s) - s0) - start))))) - (else (loop (- len 1) - (cdr start) - (cons (car start) accum)))))) - (else - ;; Compression offset - (let ((offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) - (char->ascii (cadr start))))) - (call-with-values - (lambda () (parse-name (list-tail message offset) message)) - (lambda (s ignore-start) - (values s (cddr start))))))))) - -;; parses a question in a message. returns the question and the rest of the message. -(define (parse-question start message) - (if *debug* (display "parse-question\n")) - (call-with-values - (lambda () (parse-name start message)) - (lambda (name start) - (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 (make-question name type class) start)))))) - -;; parses a resourcerecord in a message. returns the rr and the rest of the message. -(define (parse-rr start message) - (if *debug* (display "parse-rr\n")) - (call-with-values - (lambda () (parse-name start message)) - (lambda (name start) - (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 of data: - (let loop ((len len) - (start start) - (accum '())) - (if (zero? len) - (values (make-rr name type class ttl (parse-rr-data type class (reverse! accum) message)) start) - (loop (- len 1) - (cdr start) - (cons (car start) accum))))))))))) - -;;; -- rr-data-type records - -(define-record rr-data-a - ip) - -(define-record rr-data-ns - name) - -(define-record rr-data-cname - name) - -;; ### -;; hinfo not correctly implemented, trying to find examples -(define-record rr-data-hinfo - data) - -(define-record rr-data-mx - preference - exchanger) - -(define-record rr-data-ptr - name) - -(define-record rr-data-soa - mname - rname - serial - refresh - retry - expire - minimum) - -;; ### same as hinfo -(define-record rr-data-txt - text) - -;; ### same as hinfo and txt -(define-record rr-data-wks - data) - -;; - -(define (parse-rr-data type class data message) - (if *debug* (display "parse-rr-data\n")) - (cond - ((eq? type 'a) - (make-rr-data-a (ip->string data))) - - ((eq? type 'ns) - (make-rr-data-ns (call-with-values - (lambda () (parse-name data message)) - (lambda (name rest) name)))) - - ((eq? type 'cname) - (make-rr-data-cname (call-with-values - (lambda () (parse-name data message)) - (lambda (name rest) name)))) - - ((eq? type 'mx) - (make-rr-data-mx (octet-pair->number (car data) (cadr data)) - (call-with-values - (lambda ()(parse-name (cddr data) message)) - (lambda (name rest) name)))) - - ((eq? type 'ptr) - (make-rr-data-ptr (call-with-values - (lambda () (parse-name data message)) - (lambda (name rest) name)))) - - ((eq? type 'soa) - (call-with-values - (lambda () (parse-name data message)) - (lambda (mname rest) - (call-with-values - (lambda () (parse-name rest message)) - (lambda (rname rest) - (let ((serial (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) - (rest (cddddr rest))) - (let ((refresh (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) - (rest (cddddr rest))) - (let ((retry (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) - (rest (cddddr rest))) - (let ((expire (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) - (rest (cddddr rest))) - (let ((minimum (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) - (rest (cddddr rest))) - (make-rr-data-soa mname rname serial refresh retry expire minimum))))))))))) - - ((eq? type 'hinfo) - (make-rr-data-hinfo (list->string data))) - - ((eq? type 'txt) - (make-rr-data-txt (list->string data))) - - ((eq? type 'wks) - (make-rr-data-wks data)) - - (else (list data)))) - -;; parses n-times a message with parse. returns a list of parse-returns. -(define (parse-n parse start message n) - (if *debug* (display "parse-n\n")) - (let loop ((n n) (start start) (accum '())) - (if (zero? n) - (values (reverse! accum) start) - (call-with-values - (lambda () (parse start message)) - (lambda (rr start) - (loop (- n 1) start (cons rr accum))))))) - -;; parses a message-headers flags. returns the flags. -(define (parse-flags message) - (if *debug* (display "parse-flags\n")) - (let ((v0 (list-ref message 2)) - (v1 (list-ref message 3))) - ;; Check for error code: - (let ((rcode (bitwise-and #xf (char->ascii v1))) - (z (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4)) - (ra (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7)) - (rd (bitwise-and 1 (char->ascii v0))) - (tc (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1)) - (aa (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2)) - (opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3)) - (qr (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7))) - (make-flags qr opcode aa tc rd ra z rcode)))) - - -;; parses a message-header. returns the header. -(define (parse-header message) - (if *debug* (display "parse-header\n")) - (let ((id (octet-pair->number (list-ref message 0) (list-ref message 1))) - (flags (parse-flags message)) - (qd-count (octet-pair->number (list-ref message 4) (list-ref message 5))) - (an-count (octet-pair->number (list-ref message 6) (list-ref message 7))) - (ns-count (octet-pair->number (list-ref message 8) (list-ref message 9))) - (ar-count (octet-pair->number (list-ref message 10) (list-ref message 11)))) - (make-header id flags qd-count an-count ns-count ar-count))) - - -;; parses a message. returns the parsed message. -(define (parse message) - (if *debug* (display "parse\n")) - (let* ((header (parse-header message)) - (start (list-tail message 12))) - (call-with-values - (lambda () (parse-n parse-question start message (header:qdc header))) - (lambda (qds start) - (call-with-values - (lambda () (parse-n parse-rr start message (header:anc header))) - (lambda (ans start) - (call-with-values - (lambda () (parse-n parse-rr start message (header:nsc header))) - (lambda (nss start) - (call-with-values - (lambda () (parse-n parse-rr start message (header:arc header))) - (lambda (ars start) - (if (not (null? start)) - (signal 'parse-error)) - (make-message header qds ans nss ars message))))))))))) - - - -;;; -- send, receive and validate message - -;; checks if the received reply is valid. returns #t or error-msg. -(define (reply-acceptable? reply query) - (if *debug* (display "reply-acceptable?\n")) - ;; Check correct id - (if (not (and (char=? (car reply) (car query)) - (char=? (cadr reply) (cadr query)))) - (display "send-receive-message: bad reply id from server")) - ;; Check for error code: - (let ((rcode (flags:rcode (parse-flags reply)))) - (if (not (zero? rcode)) - (case rcode - ((1) (signal 'dns-format-error)) - ((2) (signal 'dns-server-failure)) - ((3) (signal 'dns-name-error)) - ((4) (signal 'dns-not-implemented)) - ((5) (signal 'dns-refused)))))) - -;; #t if message is truncated (could happen via UDP) -(define (truncated? reply) - (let ((trunc (flags:trunc (parse-flags reply)))) - trunc)) - - -;; connects to nameserver and sends and receives messages. returns the reply. -;; here: via TCP -(define (send-receive-message-tcp nameserver question) - (if *debug* (display "send-receive-message\n")) - (let* ((query question) - (reply - (let ((socket (socket-connect protocol-family/internet - socket-type/stream - nameserver 53))) - (let ((r (socket:inport socket)) - (w (socket:outport socket))) - (dynamic-wind - (lambda () - 'nothing-to-be-done-before) - (lambda () - (display (list->string (add-size-tag query)) w) - (force-output w) - - (let ((a (read-char r)) - (b (read-char r))) - (let ((len (octet-pair->number a b))) - (let ((s (read-string len r))) - (if (not (= len (string-length s))) - (signal 'unexpected-eof-from-server)) - (string->list s))))) - (lambda () - (close-socket socket))))))) - (reply-acceptable? reply query) - (parse reply))) - -;; here: via UDP -(define (send-receive-message-udp nameserver question) - (if *debug* (display "send-receive-message\n")) - (let* ((query question) - (reply - (let ((socket (socket-connect protocol-family/internet - socket-type/datagram - nameserver 53))) - (let ((r (socket:inport socket)) - (w (socket:outport socket))) - (dynamic-wind - (lambda () - 'nothing-to-be-done-before) - (lambda () - (display (list->string query) w) - (force-output w) - (let ((s (read-string/partial 512 r))) ; 512 is the maximum udp-message size - (string->list s))) - (lambda () - (close-socket socket))))))) - (reply-acceptable? reply query) - (if (truncated? reply) - (send-receive-message-tcp nameserver question) - (parse reply)))) - - -;;; -- cache - -;; creates the cache, an emoty string-table -(define cache (make-string-table)) - -;; resets the cache -(define (dns-clear-cache) - (set! cache (make-string-table))) - -;; searches in a dns-msg for the shortest ttl. this is needed for cache-management. -(define (find-shortest-ttl dns-msg) - (if *debug* (display "find-shortest-ttl\n")) - (letrec ((minimum #f) - (find-shortest-ttl-1 - (lambda (dns-msg) - (cond - ((dns-message? dns-msg) - (find-shortest-ttl-1 (dns-message:reply dns-msg))) - ((message? dns-msg) - (for-each (lambda (x) (find-shortest-ttl-1 x)) (message:answers dns-msg)) - (for-each (lambda (x) (find-shortest-ttl-1 x)) (message:nameservers dns-msg)) - (for-each (lambda (x) (find-shortest-ttl-1 x)) (message:additionals dns-msg)) - minimum) - ((rr? dns-msg) - (cond - ((not minimum) (set! minimum (rr:ttl dns-msg))) - (else - (if (and (not minimum) (> minimum (rr:ttl dns-msg))) - (set! minimum (rr:ttl dns-msg)))))))))) - (find-shortest-ttl-1 dns-msg))) - -;; makes a dns-query. optional cache-check. -;; returns a dns-message with cache-flag and either cache-data or new received data. -(define (dns-query/cache question use-cache? protocol nameserver tried) - (if *debug* (display "dns-query/cache\n")) - (let ((send-receive-message - (cond - ((eq? protocol 'tcp) send-receive-message-tcp) - ((eq? protocol 'udp) send-receive-message-udp)))) - (let ((dns-query - (lambda () - (if *debug* (display "dns-query/cache:dns-query\n")) - ;; returns new retrieved data - (make-dns-message (parse question) (send-receive-message nameserver question) #f protocol (reverse tried)))) - (dns-query-with-cache - (lambda () - (if *debug* (display "dns-query/cache:dns-query-with-cache\n")) - (let* ((qds (message:questions (parse question))) - ;; cache-key relevant data - (name (question:name (car qds))) - (type (question:type (car qds))) - (class (question:class (car qds))) - (key (format #f "~a;~a;~a;~a" nameserver name type class)) - (found-data (table-ref cache key))) - (cond - ((and found-data - ;; checks if cached-data is still valid - (< (time) (+ (cache:time found-data) (cache:ttl found-data)))) - ;; returns cached data - (make-dns-message (parse question) (cache:answer found-data) #t protocol (reverse tried))) - (else - (let ((reply-msg (send-receive-message nameserver question))) - (if *debug* (display "write to cache\n")) - (table-set! cache key (make-cache reply-msg (find-shortest-ttl reply-msg) (time))) - ;; returns new retrieved data and updates cache - (make-dns-message (parse question) reply-msg #f protocol (reverse tried))))))))) - (if use-cache? - (dns-query-with-cache) - (dns-query))))) - -;; dns and recursion -;; recursion means, if the demanded information is not available from the -;; nameserver, another nameserver (usualy an authority) has to be contacted. -;; normally the recursion is done for us by the nameserver istself, but -;; this feature is technically optional (RFC 1035). -;; dns-get-information implements the resovler-side recursion. -;; it returns a dns-message -(define (dns-get-information question use-cache? protocol nameserver check-answer) - (if *debug* (display "dns-get-information\n")) - (letrec ((tried (list nameserver)) - ;; with every (even unanswerd) requests authoritative nameservers are sent back - ;; try-recursive tries to get information from these nameservers - (try-recursive - (lambda (auth? nss) - (if (or auth? (null? nss)) - (signal 'bad-address) - (let* ((ns (and (eq? (rr:type (car nss)) 'a) (rr-data-a:ip (rr:data (car nss))))) - (dns-msg (if (and ns - (not (member ns tried)) - (set! tried (cons ns tried))) - (dns-query/cache question use-cache? protocol ns tried) - (try-recursive auth? (cdr nss))))) - (check-success dns-msg))))) - ;; checks if the answer is useful. returns a dns-message. - (check-success - (lambda (dns-msg) - (if *debug* (display "dns-get-information:check-success\n")) - (let ((useful-answer? (check-answer dns-msg))) - (if useful-answer? - dns-msg - (let ((auth? (not (zero? (flags:auth (header:flags (message:header (dns-message:reply dns-msg))))))) - ;; other nameservers names are found in the nameserver-part, - ;; but their ip-adresses are found in the additonal-rrs - (other-nameservers (filter (lambda (elem) (eq? (rr:type elem) 'a)) - (message:additionals (dns-message:reply dns-msg))))) - (try-recursive auth? other-nameservers))))))) - (check-success (dns-query/cache question use-cache? protocol nameserver tried)))) - - - -;; parses the resolv.conf file and returns a list of found nameserver -(define (dns-find-nameserver-list) - (with-input-from-file "/etc/resolv.conf" - (lambda () - (let loop ((ns '())) - (let ((l (read-line))) - (cond - ((eof-object? l) - (if (null? ns) - (signal 'no-nameservers) - ns)) - ((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l) - => (lambda (match) - (loop (append ns (list (match:substring match 1)))))) - (else - (loop ns)))))))) - - -;; returns the first found nameserver -(define (dns-find-nameserver) - (let ((ns (dns-find-nameserver-list))) - (if (null? ns) - (signal 'no-nameservers) - (car ns)))) - - - -;; concurrent-lookup -;; starts a -lookup to all nameservers in (dns-find-nameserver-list) -(define (concurrent-lookup lookup name) - (let* ((return 'no-value) - (lock (make-lock)) - (queue (make-queue)) - (nameserver-list (dns-find-nameserver-list))) - - (obtain-lock lock) - - (spawn (lambda () - (for-each (lambda (nameserver) - (spawn - (lambda () - (display "query sent to ")(display nameserver)(display " \n") - (let* ((result (apply lookup (list name nameserver)))) - (enqueue! queue result) - (display "received reply from ")(display nameserver)(display ": ")(display result)(newline) - (release-lock lock))))) - (dns-find-nameserver-list)))) - - (let loop ((count (length nameserver-list))) - (obtain-lock lock) - (let ((result (dequeue! queue))) - (if (or result (= 1 (length nameserver-list))) - result - (loop (- count 1))))))) - -;; checks the arguments of the dns-lookup-* functions. -;; if a nameserver-name is given and not a nameserver-ip -;; (dns-lookup-name nameserver) is called. -(define (check-args args) - (if (null? args) - (dns-find-nameserver) - (let ((nameserver (car args))) - (if (ip? nameserver) - nameserver - (dns-lookup-name nameserver))))) - - -;; dns-lookup with more options than dns-lookup-* -;; optional: nameserver could be passed to the function. -(define (dns-lookup name type . args) - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (dns-error-messages condition more) - (exit #f)) - (lambda () - (let* ((ip-string (ip-string->in-addr name)) - (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address - (make-octet-query-message (random 256) ip-string type 'in) - (make-octet-query-message (random 256) name type 'in))) - (use-cache? #t) - (protocol 'udp) - (nameserver (check-args args)) - (check-answer (lambda (dns-msg) #t)) - (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) - (answers (message:answers (dns-message:reply dns-msg)))) - (if (not (null? answers)) - (for-each (lambda (x) (show-dns-message x)(newline)) answers) - (display "no answers received - but resolved information in other sections.\n")) - dns-msg)))))) - - - -;; looks up a hostname, returns an ip. -;; (dns-lookup-name [nameserver]) -(define (dns-lookup-name name . args) - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (dns-error-messages condition more) - (exit #f)) - (lambda () - (let* ((ip-string (ip-string->in-addr name)) - (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address - (signal 'not-a-hostname) - (make-octet-query-message (random 256) name 'a 'in))) - (use-cache? #t) - (protocol 'udp) - (nameserver (check-args args)) - (check-answer (lambda (dns-msg) - (let* ((reply (dns-message:reply dns-msg)) - (answers (message:answers reply))) - (not (null? (filter-type answers 'a)))))) - (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) - (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a))) - (rr-data-a:ip (rr:data (car answers))))))))) - - -;; looks up an ip, returns a hostname -;; (dns-inverse-lookup [nameserver]) -(define (dns-inverse-lookup ip . args) - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (dns-error-messages condition more) - (exit #f)) - (lambda () - (let* ((ip-string (ip-string->in-addr ip)) - (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address - (make-octet-query-message (random 256) ip-string 'ptr 'in) - (signal 'not-a-ip))) - (use-cache? #t) - (protocol 'udp) - (nameserver (check-args args)) - (check-answer (lambda (dns-msg) - (let* ((reply (dns-message:reply dns-msg)) - (answers (message:answers reply))) - (not (null? (filter-type answers 'ptr)))))) - (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) - (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr))) - (rr-data-ptr:name (rr:data (car answers))))))))) - -(define dns-lookup-ip dns-inverse-lookup) - - -;; looks up an authoritative nameserver for a hostname -;; returns a list of nameservers -;; (dns-lookup-nameserver [nameserver]) -(define (dns-lookup-nameserver name . args) - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (dns-error-messages condition more) - (exit #f)) - (lambda () - (let* ((ip-string (ip-string->in-addr name)) - (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address - (signal 'not-a-hostname) - (make-octet-query-message (random 256) name 'ns 'in))) - (use-cache? #t) - (protocol 'udp) - (nameserver (check-args args)) - (check-answer (lambda (dns-msg) - (let* ((reply (dns-message:reply dns-msg)) - (answers (message:answers reply)) - (nameservers (message:nameservers reply))) - (or (not (null? (filter-type nameservers 'soa))) - (not (null? (filter-type answers 'ns))))))) - (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) - (reply (dns-message:reply dns-msg)) - (soa (filter-type (message:nameservers reply) 'soa)) - (nss (filter-type (message:answers reply) 'ns)) - (add (filter-type (message:additionals reply) 'a))) - (if (null? nss) - (list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa))))) - (map (lambda (elem) (rr-data-a:ip (rr:data elem))) add)))))))) - - -;; looks up a mail-exchanger for a hostname. -;; returns a list of mail-exchanger, sorted by their preference -;; if there are no mx-records in the answer-section, -;; implementation based on RFC2821 -;; (dns-lookup-mail-exchanger [nameserver]) -(define (dns-lookup-mail-exchanger name . args) - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (dns-error-messages condition more) - (exit #f)) - (lambda () - (let* ((ip-string (ip-string->in-addr name)) - (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address - (signal 'not-a-hostname) - (make-octet-query-message (random 256) name 'mx 'in))) - (use-cache? #t) - (protocol 'tcp) - (nameserver (check-args args)) - (check-answer (lambda (dns-msg) - (let* ((reply (dns-message:reply dns-msg)) - (answers (message:answers reply)) - (nameservers (message:nameservers reply))) - (or (not (null? (filter-type answers 'mx))) - (not (null? (filter-type answers 'cname))) - (not (null? (filter-type answers 'a))))))) - (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) - (reply (dns-message:reply dns-msg)) - (mx (filter-type (message:answers reply) 'mx)) - (soa (filter-type (message:nameservers reply) 'soa)) - (cname (filter-type (message:answers reply) 'cname)) - (a (filter-type (message:answers reply) 'a))) - - (cond - ((not (null? a)) - (list (rr-data-a:ip (rr:data (car a))))) - ((not (null? cname)) - (dns-lookup-mail-exchanger (rr-data-cname:name (rr:data (car cname))))) - ((null? mx) - (list (rr-data-soa:rname (rr:data (car soa))))) - (else - (map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx)))))))))) - - - - -;;; pretty-prints a dns-msg -(define (show-dns-message dns-msg) - (let* ((d - (lambda (n s1 s2) - (letrec ((loop (lambda (n) - (if (zero? n) - "" - (string-append " " (loop (- n 1))))))) - (display (loop n)) - (display s1) - (display ": ") - (display s2) - (newline))))) - - (cond - ((dns-message? dns-msg) - (begin - (d 0 "DNS-MESSAGE" "") - (d 1 "QUERY" "")(show-dns-message (dns-message:query dns-msg))(newline) - (d 1 "REPLY" "")(show-dns-message (dns-message:reply dns-msg))(newline) - (d 1 "CACHE?" (if (dns-message:cache? dns-msg) - "found in cache" - "not found in cache")) - (d 1 "PROTOCOL" (let ((protocol (dns-message:protocol dns-msg))) - (cond - ((eq? protocol 'tcp) "TCP") - ((eq? protocol 'udp) "UDP")))) - (d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message:tried-nameservers dns-msg)) 1) - (begin - (display " had perform recursion: ") - (dns-message:tried-nameservers dns-msg)) - (begin - (display " without recursion: ") - (dns-message:tried-nameservers dns-msg)))))) - ((message? dns-msg) - (begin - (d 2 "MESSAGE" "") - (d 3 "Header " "")(show-dns-message (message:header dns-msg)) - (d 3 "Questions " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:questions dns-msg)) - (d 3 "Answers " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:answers dns-msg)) - (d 3 "Nameservers" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:nameservers dns-msg)) - (d 3 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:additionals dns-msg)))) - ((header? dns-msg) - (begin - (d 4 "id" (header:id dns-msg)) - (d 4 "Flags" "")(show-dns-message (header:flags dns-msg)) - (d 4 "question-count " (header:qdc dns-msg)) - (d 4 "answer-count " (header:anc dns-msg)) - (d 4 "nameserver-count " (header:nsc dns-msg)) - (d 4 "additional-count " (header:arc dns-msg)))) - ((flags? dns-msg) - (begin - (d 5 "querytype" (flags:querytype dns-msg)) - (d 5 "opcode" (flags:opcode dns-msg)) - (d 5 "auth" (flags:auth dns-msg)) - (d 5 "trunc" (flags:trunc dns-msg)) - (d 5 "recursiondesired" (flags:recursiondesired dns-msg)) - (d 5 "recursionavailable" (flags:recursionavailable dns-msg)) - (d 5 "z" (flags:z dns-msg)) - (d 5 "rcode" (flags:rcode dns-msg)))) - ((question? dns-msg) - (begin - (d 4 "name " (question:name dns-msg)) - (d 4 "type " (question:type dns-msg)) - (d 4 "class" (question:class dns-msg)))) - ((rr? dns-msg) - (begin - (d 4 "name " (rr:name dns-msg)) - (d 4 "type " (rr:type dns-msg)) - (d 4 "class" (rr:class dns-msg)) - (d 4 "ttl " (rr:ttl dns-msg)) - (d 4 "data " "") (show-dns-message (rr:data dns-msg)))) - ((rr-data-a? dns-msg) - (d 5 "ip " (rr-data-a:ip dns-msg))) - ((rr-data-ns? dns-msg) - (d 5 "name " (rr-data-ns:name dns-msg))) - ((rr-data-cname? dns-msg) - (d 5 "name " (rr-data-cname:name dns-msg))) - ((rr-data-mx? dns-msg) - (begin - (d 5 "preference " (rr-data-mx:preference dns-msg)) - (d 5 "exchanger " (rr-data-mx:exchanger dns-msg)))) - ((rr-data-ptr? dns-msg) - (d 5 "name " (rr-data-ptr:name dns-msg))) - ((rr-data-soa? dns-msg) - (begin - (d 5 "mname " (rr-data-soa:mname dns-msg)) - (d 5 "rname " (rr-data-soa:rname dns-msg)) - (d 5 "serial " (rr-data-soa:serial dns-msg)) - (d 5 "refresh " (rr-data-soa:refresh dns-msg)) - (d 5 "expire " (rr-data-soa:expire dns-msg)) - (d 5 "minimum " (rr-data-soa:expire dns-msg)))) - ;; ### - ((rr-data-hinfo? dns-msg) - (d 5 "data " (rr-data-hinfo:data dns-msg))) - ((rr-data-txt? dns-msg) - (d 5 "text " (rr-data-txt:text dns-msg))) - ((rr-data-wks? dns-msg) - (d 5 "data " (rr-data-wks:data dns-msg))) - - ))) diff --git a/ecm-utilities.scm b/ecm-utilities.scm deleted file mode 100644 index 4ecf3ee..0000000 --- a/ecm-utilities.scm +++ /dev/null @@ -1,57 +0,0 @@ -;; ecm-utilities.scm -- Utility procedures for ecm-net code -;; -;; $Id: ecm-utilities.scm,v 1.4 2002/03/29 16:44:04 interp Exp $ -;; -;; Please send suggestions and bug reports to - - -;; please tell me if this doesn't work on your system. -(define (system-fqdn) - (let ((sysname (system-name))) - (if (string-index sysname #\.) - sysname - (nslookup-fqdn)))) - -;; This doesn't work on my system. Probably it is not configured well. -;; Nevertheless, the alternative seems better to me -;(define (nslookup-fqdn) -; (let* ((cmd (format #f "nslookup ~a" (system-name))) -; (raw (string-join (run/strings (nslookup ,(system-name))))) -; (match (string-match "Name: +([-a-zA-Z0-9.]+)" raw))) -; (display raw) -; (match:substring match 1))) - -(define (nslookup-fqdn) - (host-info:name (host-info (system-name)))) -; another easy alternative: -; (car (run/strings (hostname "--long")))) - - -;; prefer this to :optional -(define (safe-first x) (and (not (null? x)) (car x))) -(define (safe-second x) (and (not (null? x)) (not (null? (cdr x))) (cadr x))) - -(define (write-crlf port) - (write-string "\r\n" port) - (force-output port)) - - -(define (dump fd) - (let loop ((c (read-char fd))) - (cond ((not (eof-object? c)) - (write-char c) - (loop (read-char fd)))))) - - -(define-syntax when - (syntax-rules () - ((when bool body1 body2 ...) - (if bool (begin body1 body2 ...))))) - - -(define-syntax unless - (syntax-rules () - ((unless bool body1 body2 ...) - (if (not bool) (begin body1 body2 ...))))) - -;; EOF diff --git a/format-net.scm b/format-net.scm deleted file mode 100644 index 30f419e..0000000 --- a/format-net.scm +++ /dev/null @@ -1,32 +0,0 @@ -;; Does pretty-print of internet-addresses (IPv4) -;; ADDRESS address to pretty-print -;; SEPERATOR optional, defaults to ".", seperator between address-parts -;; Example: -;; (format-internet-host-address #x0a00ffff) -;; ==> "10.0.255.255" -;; (format-internet-host-address #x0a00ffff ":") -;; ==> "10:0:255:255" - -(define (format-internet-host-address address . maybe-separator) - - (let ((extract (lambda (shift) - (number->string - (bitwise-and (arithmetic-shift address (- shift)) - 255))))) - - (let-optionals maybe-separator ((separator ".")) - (string-append - (extract 24) separator (extract 16) separator - (extract 8) separator (extract 0))))) - -;; does pretty-print of ports -;; Example: -;; (format-port #x0aff) -;; => "10,255" - -(define (format-port port) - (string-append - (number->string (bitwise-and (arithmetic-shift port -8) 255)) - "," - (number->string (bitwise-and port 255)))) - diff --git a/ftp-obsolete.scm b/ftp-obsolete.scm deleted file mode 100644 index 1ec728c..0000000 --- a/ftp-obsolete.scm +++ /dev/null @@ -1,24 +0,0 @@ -; maps obsolete ftp-procedure names to new ftp procedure names -; by Andreas Bernauer (2002) - -(define ftp:connect ftp-connect) -(define ftp:login ftp-login) -(define ftp:type ftp-type) -(define ftp:rename ftp-rename) -(define ftp:delete ftp-delete) -(define ftp:cd ftp-cd) -(define ftp:cdup ftp-cdup) -(define ftp:pwd ftp-pwd) -(define ftp:rmdir ftp-rmdir) -(define ftp:mkdir ftp-mkdir) -(define ftp:modification-time ftp-modification-time) -(define ftp:size ftp-size) -(define ftp:abort ftp-abort) -(define ftp:quit ftp-quit) -(define ftp:ls ftp-ls) -(define ftp:dir ftp-dir) -(define ftp:get ftp-get) -(define ftp:put ftp-put) -(define ftp:append ftp-append) -(define ftp:quot ftp-quot) - diff --git a/ftp.scm b/ftp.scm deleted file mode 100644 index ea22b74..0000000 --- a/ftp.scm +++ /dev/null @@ -1,575 +0,0 @@ -;;; ftp.scm -- an FTP client library for the Scheme Shell -;; -;; $Id: ftp.scm,v 1.5 2002/04/25 09:52:42 interp Exp $ -;; -;; Please send suggestions and bug reports to - - - -;;; Overview ========================================================= -;; -;; This module lets you transfer files between networked machines from -;; the Scheme Shell, using the File Transfer Protocol as described -;; in rfc959. The protocol specifies the behaviour of a server -;; machine, which runs an ftp daemon (not implemented by this module), -;; and of clients (that's us) which request services from the server. - - -;;; Entry points ======================================================= -;; -;; (ftp-connect host [logfile]) -> connection -;; Open a command connection with the remote machine HOST. -;; Optionally start logging the conversation with the server to -;; LOGFILE, which will be appended to if it already exists, and -;; created otherwise. Beware, the LOGFILE contains passwords in -;; clear text (it is created with permissions og-rxw) ! -;; -;; (ftp-login connection [login passwd]) -> status -;; Log in to the remote host. If a login and password are not -;; provided, they are first searched for in the user's ~/.netrc -;; file, or default to user "anonymous" and password "user@host" -;; -;; (ftp-type connection type) -> status -;; Change the transfer mode for future data connections. This may -;; be either 'ascii or 'text, respectively, for transfering text files, -;; or 'binary for transfering binary files. If type is a string it -;; is sent verbatim to the server. -;; -;; (ftp-rename connection oldname newname) -> status -;; Change the name of oldname on the remote host to newname -;; (assuming sufficient permissions). oldname and newname are -;; strings; if prefixed with "/" they are taken relative to the -;; server's root, and otherwise they are relative to the current -;; directory. Note that in the case of anonymous ftp (user -;; "anonymous" or "ftp"), the server root is different from the -;; root of the servers's filesystem. -;; -;; (ftp-delete connection file) -> status -;; Delete file from the remote host (assuming the user has -;; appropriate permissions). -;; -;; (ftp-cd connection dir) -> status -;; Change the current directory on the server. -;; -;; (ftp-cdup connection) -> status -;; Move to the parent directory on the server. -;; -;; (ftp-pwd connection) -> string -;; Return the current directory on the remote host, as a string. -;; -;; (ftp-ls connection) -> status -;; Provide a listing of the current directory's contents, in short -;; format, ie as a list of filenames. -;; -;; (ftp-dir connection) -> status -;; Provide a listing of the current directory's contents, in long -;; format. Most servers (Unix, MS Windows, MacOS) use a standard -;; format with one file per line, with the file size and other -;; information, but other servers (VMS, ...) use their own format. -;; -;; (ftp-get connection remote-file [local-file]) -> status | string -;; Download remote-file from the FTP server. If local-file is a -;; string, save the data to local-file on the local host; -;; otherwise save to a local file named remote-file. remote-file -;; and local-file may be absolute file names (with a leading `/'), -;; or relative to the current directory. It local-file is #t, -;; output data to (current-output-file), and if it is #f return -;; the data as a string. -;; -;; (ftp-put connection local-file [remote-file]) -> status -;; Upload local-file to the FTP server. If remote-file is -;; specified, the save the data to remote-file on the remote host; -;; otherwise save to a remote file named local-file. local-file -;; and remote-file may be absolute file names (with a leading -;; `/'), or relative to the current directory. -;; -;; (ftp-rmdir connection dir) -> status -;; Remove the directory DIR from the remote host (assuming -;; sufficient permissions). -;; -;; (ftp-mkdir connection dir) -> status -;; Create a new directory named DIR on the remote host (assuming -;; sufficient permissions). -;; -;; (ftp-modification-time connection file) -> date -;; Request the time of the last modification of FILE on the remote -;; host, and on success return a Scsh date record. This command is -;; not part of RFC959 and is not implemented by all servers, but -;; is useful for mirroring. -;; -;; (ftp-size connection file) -> integer -;; Return the size of FILE in bytes. -;; -;; (ftp-abort connection) -> status -;; Abort the current data transfer. Not particularly useful with -;; this implementation since the data transfer commands only -;; return once the transfer is complete. -;; -;; (ftp-quit connection) -> status -;; Close the connection to the remote host. The connection object -;; is useless after a quit command. - - -;;; Unimplemented ===================================================== -;; -;; This module has no support for sites behind a firewall (because I -;; am unable to test it). It shouldn't be very tricky; it only -;; requires using passive mode. Might want to add something like the -;; /usr/bin/ftp command `restrict', which implements data port range -;; restrictions. -;; -;; The following rfc959 commands are not implemented: -;; -;; * ACCT (account; this is ignored by most servers) -;; * SMNT (structure mount, for mounting another filesystem) -;; * REIN (reinitialize connection) -;; * LOGOUT (quit without interrupting ongoing transfers) -;; * STRU (file structure) -;; * ALLO (allocate space on server) - - -;;; Portablitity ===================================================== -;; -;; * the netrc.scm module for parsing ~/.netrc files -;; * scsh socket code -;; * scsh records -;; * receive for multiple values -;; * Scheme48 signals/handlers - - -;;; Related work ====================================================== -;; -;; * rfc959 describes the FTP protocol; see -;; http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html -;; -;; * /anonymous@sunsite.unc.edu:/pub/Linux/libs/ftplib.tar.gz is a -;; library similar to this one, written in C, by Thomas Pfau -;; -;; * FTP.pm is a Perl module with similar functionality (available -;; from http://www.perl.com/CPAN) -;; -;; * Emacs gets transparent remote file access from ange-ftp.el by -;; Ange Norman. However, it cheats by using /usr/bin/ftp -;; -;; * Siod (a small-footprint Scheme implementation by George Carette) -;; comes with a file ftp.scm with a small subset of these functions -;; defined - - -;;; TODO ============================================================ -;; -;; * handle passive mode and firewalls -;; * Unix-specific commands such as SITE UMASK, SITE CHMOD -;; * object-based interface? (like SICP message passing) -;; * improved error handling -;; * a lot of the calls to format could be replaced by calls to -;; string-join. Maybe format is easier to read? - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Communication is initiated by the client. The server responds to -;; each request with a three digit status code and an explanatory -;; message, and occasionally with data (which is sent via a separate, -;; one-off channel). The client starts by opening a command connection -;; to a well known port on the server machine. Messages send to the -;; server are of the form -;; -;; CMD [ arg ] -;; -;; Replies from the server are of the form -;; -;; xyz Informative message -;; -;; where xyz is a three digit code which indicates whether the -;; operation succeeded or not, whether the server is waiting for more -;; data, etc. The server may also send multiline messages of the form -;; -;; xyz- Start of multiline message -;; [ + More information ]* -;; xyz End of multiline message -;; -;; Some of the procedures in this module extract useful information -;; from the server's reply, such as the size of a file, or the name of -;; the directory we have moved to. These procedures return either the -;; extracted information, or #f to indicate failure. Other procedures -;; return a "status", which is either the server's reply as a string, -;; or #f to signify failure. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; beware, the log file contains password information! -;;: string [ x string x port] -> connection -(define (ftp-connect host . args) - (let-optionals* args ((logfile #f)) - (let* ((LOG (and logfile - (open-output-file logfile - (if (file-exists? logfile) - (bitwise-ior open/write open/append) - (bitwise-ior open/write open/create)) - #o600))) - (hst-info (host-info host)) - (hostname (host-info:name hst-info)) - (srvc-info (service-info "ftp" "tcp")) - (sock (socket-connect protocol-family/internet - socket-type/stream - hostname - (service-info:port srvc-info))) - (connection (make-ftp-connection hostname - sock - LOG "" ""))) - (ftp-log connection - (format #f "~%-- ~a: opened ftp connection to ~a" - (date->string (date)) ; doesn't seem to be buggy in v0.6 - ;"Dummy date" ; (format-time-zone) is buggy in v0.5.1 - hostname)) - (ftp-read-response connection "220") ; the initial welcome banner - connection))) - -;; Send user information to the remote host. Args are optional login -;; and password. If they are not provided, the Netrc module is used to -;; try to determine a login and password for the server. If not found we -;; default to login "anonymous" with password user@host. -;;: connection [ x string x password ] -> status -(define (ftp-login connection . args) - (let ((netrc-record (netrc:parse))) - (let-optionals* args - ((login - (netrc:lookup-login netrc-record - (ftp-connection:host-name connection))) - (password - (netrc:lookup-password netrc-record - (ftp-connection:host-name connection)))) - (set-ftp-connection:login connection login) - (set-ftp-connection:password connection password) - (ftp-send-command connection (format #f "USER ~a" login) "...") ; "331" - (ftp-send-command connection (format #f "PASS ~a" password) "2..")))) ; "230" - -;; Type must be one of 'binary or 'text or 'ascii, or a string which will be -;; sent verbatim -;;: connection x symbol|string -> status -(define (ftp-type connection type) - (let ((ttype (cond - ((string? type) type) - ((eq? type 'binary) "I") - ((or (eq? type 'ascii) - (eq? type 'text)) "A") - (else - (call-error "type must be one of 'binary or 'text or 'ascii" ftp-type type))))) - (ftp-send-command connection (format #f "TYPE ~a" ttype)))) - -;;: connection x string x string -> status -(define (ftp-rename connection oldname newname) - (ftp-send-command connection (format #f "RNFR ~a" oldname) "35.") - (ftp-send-command connection (format #f "RNTO ~a" newname) "25.")) - -;;: connection x string -> status -(define (ftp-delete connection file) - (ftp-send-command connection (format #f "DELE ~a" file) "25.")) - -;;: connection x string -> status -(define (ftp-cd connection dir) - (ftp-send-command connection (format #f "CWD ~a" dir))) - -;;: connection -> status -(define (ftp-cdup connection) - (ftp-send-command connection "CDUP" "250")) - - -;;: on success return the new directory as a string -(define (ftp-pwd connection) - (let* ((response (ftp-send-command connection "PWD" "2..")) ;; 257 - (match (string-match "[0-9][0-9][0-9] \"(.*)\" " (or response "")))) - (match:substring match 1))) - -;;: connection x string -> status -(define (ftp-rmdir connection dir) - (ftp-send-command connection (format #f "RMD ~a" dir))) - -;;: connection x string -> status -(define (ftp-mkdir connection dir) - (ftp-send-command connection (format #f "MKD ~a" dir))) - -;; On success return a Scsh date record. This message is not part of -;; rfc959 but seems to be supported by many ftp servers (it's useful -;; for mirroring) -;;: connection x string -> date -(define (ftp-modification-time connection file) - (let* ((response (ftp-send-command connection - (format #f "MDTM ~a" file))) - (match (string-match "[0-9][0-9][0-9] ([0-9]+)" (or response ""))) - (timestr (and match (match:substring match 1)))) - (and timestr - (let ((year (substring timestr 0 4)) - (month (substring timestr 4 6)) - (mday (substring timestr 6 8)) - (hour (substring timestr 8 10)) - (min (substring timestr 10 12)) - (sec (substring timestr 12 14))) - (make-date (string->number sec) - (string->number min) - (string->number hour) - (string->number mday) - (string->number month) - (- (string->number year) 1900)))))) - -;; On success return the size of the file in bytes. -;;: connection x string -> integer -(define (ftp-size connection file) - (let* ((response (ftp-send-command connection - (format #f "SIZE ~a" file) - "2.."))) - (and (string? response) - (string->number (substring response - 4 (- (string-length response) 1)))))) - -;; Abort the current data transfer. Maybe we should close the data -;; socket? -;;: connection -> status -(define (ftp-abort connection) - (ftp-send-command connection "ABOR")) - -;;: connection -> status -(define (ftp-quit connection) - (ftp-send-command connection "QUIT" "221") - (close-socket (ftp-connection:command-socket connection))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; The following commands require the use of a data connection as well -;; as the command connection. The command and the server's reply are -;; transmitted via the command connection, while the data is -;; transmitted via the data connection (you could have guessed that, -;; right?). -;; -;; The data socket is created by the client, who sends a PORT command -;; to the server to indicate on which port it is ready to accept a -;; connection. The port command specifies an IP number and a port -;; number, in the form of 4+2 comma-separated bytes. The server then -;; initiates the data transfer. A fresh data connection is created for -;; each data transfer (unlike the command connection which stays open -;; during the entire conversation with the server). -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;: connection [ x string ] -> status -(define (ftp-ls connection . maybe-dir) - (let* ((sock (ftp-open-data-connection connection))) - (ftp-send-command connection - (ftp-build-command-string "NLST" maybe-dir) - "1..") - (receive (newsock newsockaddr) - (accept-connection sock) - (dump (socket:inport newsock)) - (close-socket newsock) - (close-socket sock) - (ftp-read-response connection "2..")))) - -;;: connection [ x string ] -> status -(define (ftp-dir connection . maybe-dir) - (let* ((sock (ftp-open-data-connection connection))) - (ftp-send-command connection - (ftp-build-command-string "LIST" maybe-dir) - "1..") - (receive (newsock newsockaddr) - (accept-connection sock) - (dump (socket:inport newsock)) - (close-socket newsock) - (close-socket sock) - (ftp-read-response connection "2..")))) - - -;; maybe-local may be a filename to which the data should be written, -;; or #t to write data to stdout (to current-output-port to be more -;; precise), or #f to stuff the data in a string (which is returned), -;; or nothing to output to a local file with the same name as the -;; remote file. -;;: connection x string [x string | #t | #f] -> status | string -(define (ftp-get connection remote-file . maybe-local) - (let* ((sock (ftp-open-data-connection connection)) - (local (if (pair? maybe-local) - (car maybe-local) - 'empty)) - (OUT (cond ((string? local) (open-output-file local)) - ((eq? local #t) (current-output-port)) - ((eq? local #f) (make-string-output-port)) - (else - (open-output-file remote-file))))) - (ftp-send-command connection - (format #f "RETR ~a" remote-file) - "150") - (receive (newsock newsockaddr) - (accept-connection sock) - (with-current-output-port OUT - (dump (socket:inport newsock))) - (close-socket newsock) - (close-socket sock) - (let ((status (ftp-read-response connection "2.."))) - (if (string? local) (close OUT)) - (if (eq? local #f) - (string-output-port-output OUT) - status))))) - - -;; FIXME: should have an optional argument :rename which defaults to -;; false, which would make us upload to a temporary name and rename at -;; the end of the upload. This atomicity is important for ftp or http -;; servers which are serving a load, and to avoid problems with "no -;; space on device". - -;; optional argument maybe-remote-file is the name under which we wish -;; the file to appear on the remote machine. If omitted the file takes -;; the same name on the FTP server as on the local host. -;;: connection x string [ x string ] -> status -(define (ftp-put connection local-file . maybe-remote-file) - (let-optionals* maybe-remote-file ((remote-file #f)) - (let* ((sock (ftp-open-data-connection connection)) - (IN (open-input-file local-file)) - (cmd (format #f "STOR ~a" (or remote-file local-file)))) - (ftp-send-command connection cmd "150") - (receive (newsock newsockaddr) - (accept-connection sock) - (with-current-output-port (socket:outport newsock) (dump IN)) - (close (socket:outport newsock)) ; send the server EOF - (close-socket newsock) - (let ((status (ftp-read-response connection "2.."))) - (close IN) - (close-socket sock) - status))))) - -;;: connection x string [x string] -> status -(define (ftp-append connection local-file . maybe-remote-file) - (let-optionals* maybe-remote-file ((remote-file #f)) - (let* ((sock (ftp-open-data-connection connection)) - (IN (open-input-file local-file)) - (cmd (format #f "APPE ~a" (or remote-file local-file)))) - (ftp-send-command connection cmd "150") - (receive (newsock newsockaddr) - (accept-connection sock) - (with-current-output-port (socket:outport newsock) - (dump IN)) - (close (socket:outport newsock)) ; send the server EOF - (close-socket newsock) - (let ((status (ftp-read-response connection "2.."))) - (close IN) - (close-socket sock) - status))))) - -;; send a command verbatim to the remote server and wait for a -;; response. -;;: connection x string -> status -(define (ftp-quot connection cmd) - (ftp-send-command connection cmd)) - - -;; ------------------------------------------------------------------------ -;; no exported procedures below - -(define (ftp-open-data-connection connection) - (let* ((sock (create-socket protocol-family/internet - socket-type/stream)) - (sockaddr (internet-address->socket-address - internet-address/any - 0))) ; 0 to accept any port - (set-socket-option sock level/socket socket/reuse-address #t) - (set-socket-option sock level/socket socket/linger 120) - (bind-socket sock sockaddr) - (listen-socket sock 0) - (ftp-send-command connection ; send PORT command - (ftp-build-PORT-string (socket-local-address sock))) - sock)) - - - -;; TODO: Unix-specific commands -;; SITE UMASK 002 -;; SITE IDLE 60 -;; SITE CHMOD 755 filename -;; SITE HELP - - - -;; We cache the login and password to be able to relogin automatically -;; if we lose the connection (a la ange-ftp). Not implemented. -(define-record ftp-connection - host-name - command-socket - logfd - login - password) - -(define-condition-type 'ftp-error '(error)) -(define ftp-error? (condition-predicate 'ftp-error)) - - -(define (ftp-build-PORT-string sockaddr) - (let* ((hst-info (host-info (system-name))) - (ip-address (car (host-info:addresses hst-info)))) - (receive (hst-address srvc-port) - (socket-address->internet-address sockaddr) - (let* ((num32 ip-address) - (num24 (arithmetic-shift num32 -8)) - (num16 (arithmetic-shift num24 -8)) - (num08 (arithmetic-shift num16 -8)) - (byte0 (bitwise-and #b11111111 num08)) - (byte1 (bitwise-and #b11111111 num16)) - (byte2 (bitwise-and #b11111111 num24)) - (byte3 (bitwise-and #b11111111 num32))) - (format #f "PORT ~a,~a,~a,~a,~a,~a" - byte0 byte1 byte2 byte3 - (arithmetic-shift srvc-port -8) ; high order byte - (bitwise-and #b11111111 srvc-port) ; lower order byte - ))))) - - -(define (ftp-send-command connection command . maybe-expected) - (let-optionals* maybe-expected ((expected "2..")) - (let* ((sock (ftp-connection:command-socket connection)) - (OUT (socket:outport sock))) - (write-string command OUT) - (write-crlf OUT) - (ftp-log connection (format #f "<- ~a" command)) - (ftp-read-response connection expected)))) - - -;; This is where we check that the server's 3 digit status code -;; corresponds to what we expected. EXPECTED is a string of the form -;; "250", which indicates we are expecting a 250 code from the server, -;; or "2.." which means that we only require the first digit to be 2 -;; and don't care about the rest. If the server's response doesn't -;; match EXPECTED, we raise an ftp-error (which is catchable; look at -;; pop3.scm to see how). Since this is implemented as a regexp, you -;; can also specify more complicated acceptable responses of the form -;; "2[4-6][0-9]". The code permits you to match the server's verbose -;; message too, but beware that the messages change from server to -;; server. -(define (ftp-read-response connection . maybe-expected) - (let-optionals* maybe-expected ((expected "2..")) - (let* ((sock (ftp-connection:command-socket connection)) - (IN (socket:inport sock)) - (response (read-line IN))) - (ftp-log connection (format #f "-> ~a" response)) - (or (string-match expected response) - (signal 'ftp-error response)) - ;; handle multi-line responses - (if (equal? (string-ref response 3) #\-) - (let loop ((code (string-append (substring response 0 3) " ")) - (line (read-line IN))) - (ftp-log connection (format #f "-> ~a" line)) - (set! response (string-join (list response line "\n"))) - (or (string-match code line) - (loop code (read-line IN))))) - response))) - - -(define (ftp-build-command-string str . opt-args) - (if (string? opt-args) - (string-join (list str arg)) - str)) - -(define (ftp-log connection line) - (let ((LOG (ftp-connection:logfd connection))) - (and LOG - (write-string line LOG) - (write-string "\n" LOG) - (force-output LOG)))) - -;; EOF diff --git a/htmlout.scm b/htmlout.scm deleted file mode 100644 index d409068..0000000 --- a/htmlout.scm +++ /dev/null @@ -1,195 +0,0 @@ -;;; Simple code for doing structured html output. -*- Scheme -*- -;;; Copyright (c) 1995 by Olin Shivers. - -;;; External dependencies -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; format ; Output -;;; receive values ; Multiple-value return - -;;; - An attribute-quoter, that will map an attribute value to its -;;; HTML text representation -- surrounding it with single or double quotes, -;;; as appropriate, etc. - -;;; Printing HTML tags. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; All the emit-foo procedures have the same basic calling conventions: -;;; (emit-foo out ... [ ...]) -;;; - OUT is either a port or #t for the current input port. -;;; - Each attribute is either a (name . value) pair, which is printed as -;;; name="value" -;;; or a single symbol or string, which is simply printed as-is -;;; (this is useful for attributes that don't have values, such as the -;;; ISMAP attribute in tags). - - - -;;; - -(define (emit-tag out tag . attrs) - (let ((out (fmt->port out))) - (display "<" out) - (display tag out) - (for-each (lambda (attr) - (display #\space out) - (cond ((pair? attr) ; name="val" - (display (car attr) out) - (display "=\"" out) ; Should check for - (display (cdr attr) out) ; internal double-quote - (display #\" out)) ; etc. - (else - (display attr out)))) ; name - attrs) - (display #\> out))) - - -;;; - -(define (emit-close-tag out tag) - (format out "" tag)) - - -;;;

- -(define (emit-p . args) ; (emit-p [out attr1 ...]) - (receive (out attrs) (if (pair? args) - (let* ((out (car args))) - (values (if (eq? out #t) (current-output-port) out) - (cdr args))) - (values (current-output-port) args)) - - (apply emit-tag out 'p attrs) - (newline out) - (newline out))) - - -;;; Make Money Fast!!! - -(define (emit-title out title) ; Takes no attributes. - (format out "~a~%~%" title)) - -(define (emit-header out level text . attribs) - (apply with-tag* out (string-append "H" (number->string level)) - (lambda () (display text (fmt->port out))) - attribs)) - -;;; ...and so forth. Could stand to define a bunch of little emitters for the -;;; various tags. (define-tag-emitter ...) - - -;;; Printing out balanced ... pairs. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; (with-tag out tag (attr-elt ...) body ...) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Execute the body forms between a ... pair. -;;; The (ATTR-ELT ...) list specifies the attributes for the . -;;; It is rather like a LET-list, having the form -;;; ((name val) ...) -;;; Each NAME must be a symbol, and each VAL must be a Scheme expression -;;; whose value is the string to use as attribute NAME's value. Attributes -;;; that have no value (e.g., ISMAP) can be specified as attr-elt NAME, -;;; instead of (NAME VALUE). -;;; -;;; For example, -;;; (let ((hp "http://clark.lcs.mit.edu/~shivers")) ; My home page. -;;; (with-tag port A ((href hp-url) (name "hp")) -;;; (display "home page" port))) -;;; outputs -;;; home page - -(define-syntax with-tag - (syntax-rules () - ((with-tag out tag (attr-elt ...) body ...) - (with-tag* out 'tag (lambda () body ...) - (%hack-attr-elt attr-elt) - ...)))) - -;;; Why does this have to be top-level? -;;; Why can't this be a LET-SYNTAX inside of WITH-TAG? - -(define-syntax %hack-attr-elt - (syntax-rules () ; Build attribute-list element: - ((%hack-attr-elt (name val)) ; (name elt) => (cons 'name elt) - (cons 'name val)) - ((%hack-attr-elt name) 'name))) ; name => 'name - - -;;; Execute THUNK between a ... pair. - -(define (with-tag* out tag thunk . attrs) - (apply emit-tag out tag attrs) - (let ((out (fmt->port out))) - (call-with-values thunk - (lambda results - (newline out) - (emit-close-tag out tag) - (apply values results))))) - - -(define (fmt->port x) - (if (eq? x #t) (current-output-port) x)) - -;;; Translate text to HTML, mapping special chars such as <, >, &, and -;;; double-quote to their HTML escape sequences. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Note iso8859-1 above 127 is perfectly OK - -(define *html-entity-alist* - (list - (cons (ascii->char 60) "<") - (cons (ascii->char 62) ">") - (cons (ascii->char 38) "&") - (cons (ascii->char 34) """))) - -(define *html-entities* - (list->char-set (map car *html-entity-alist*))) - -(define *html-entity-table* - (let ((v (make-vector 256 #f))) - (for-each (lambda (entry) - (vector-set! v - (char->ascii (car entry)) - (cdr entry))) - *html-entity-alist*) - v)) - -(define (string-set-substring! t start s) - (let* ((l (string-length s)) - (end (+ l start))) - (do ((i start (+ 1 i))) - ((= i end) t) - (string-set! t i (string-ref s (- i start)))))) - -(define (escape-html s) - (let ((target-length - (string-fold (lambda (c i) - (+ i - (if (char-set-contains? *html-entities* c) - (string-length - (vector-ref *html-entity-table* - (char->ascii c))) - 1))) - 0 - s))) - (if (= target-length (string-length s)) - s - (let ((target (make-string target-length))) - (string-fold - (lambda (c i) - (+ i - (if (char-set-contains? *html-entities* c) - (let ((entity (vector-ref *html-entity-table* (char->ascii c)))) - (string-set-substring! target i entity) - (string-length entity)) - (begin - (string-set! target i c) - 1)))) - 0 - s) - target)))) - -(define (emit-text s . maybe-port) - (if (null? maybe-port) - (write-string (escape-html s)) - (write-string (escape-html s) (fmt->port (car maybe-port))))) diff --git a/ls.scm b/ls.scm deleted file mode 100644 index 9979bef..0000000 --- a/ls.scm +++ /dev/null @@ -1,332 +0,0 @@ -; ls clone in scsh - -; Mike Sperber -; Copyright (c) 1998 Michael Sperber. - -; This currently does a whole bunch of stats on every file in some -; cases. In a decent OS implementation, this stuff is cached, so -; there isn't any problem, at least not in theory :-) - -; FLAGS is a list of symbols from: -; -; all - include stuff starting with "." -; recursive - guess what -; long - output interesting information per file -; directory - display only the information for the directory named -; flag - flag files as per their types -; columns - sorts output vertically in a multicolumn format - -(define ls-crlf? (make-fluid #f)) - -(define (ls flags paths . maybe-port) - (let* ((port (optional maybe-port (current-output-port))) - (paths (if (null? paths) - (list (cwd)) - paths)) - (only-one? (null? (cdr paths)))) - (call-with-values - (lambda () (parse-flags flags)) - (lambda (all? recursive? long? directory? flag? columns?) - (real-ls paths - (if only-one? #f "") - all? recursive? long? directory? flag? columns? - port))))) - -(define (parse-flags flags) - (let ((all? (memq 'all flags)) - (recursive? (memq 'recursive flags)) - (long? (memq 'long flags)) - (directory? (memq 'directory flags)) - (flag? (memq 'flag flags)) - (columns? (memq 'columns flags))) - (values all? recursive? long? directory? flag? columns?))) - -(define (real-ls paths prefix - all? recursive? long? directory? flag? columns? - port) - (let ((first #t)) - (for-each - (lambda (path) - (if first - (set! first #f) - (ls-newline port)) - (if prefix - (format port "~A~A:~%" prefix path)) - (ls-path path all? recursive? long? directory? flag? columns? port)) - paths))) - -(define (ls-path path all? recursive? long? directory? flag? columns? port) - (cond - ((and (not directory?) ;; go into directories - (or (and (file-name-directory? path) ;; path specifies directory - (file-directory? path #t)) ;; either as a symlink (if the names end with a slash) - (file-directory? path #f))) ;; or not - (ls-directory path all? recursive? long? directory? flag? columns? port)) - (else - (if (or long? flag?) ;; see LS-DIRECTORY for details - (ls-file (cons path (file-info path #f)) long? flag? port) - (ls-file (cons path #f) long? flag? port))))) - -(define (ls-directory directory all? recursive? long? directory? flag? columns? port) -; terminology: a FILE-NAME is the name of a file -; a FILE is a pair whose car is a file-name and whose cdr is -; either its file-info-object or #f (if not needed) -; a INFO is a file-info-object - (let* ((directory (file-name-as-directory directory)) - (substantial-directory (string-append directory ".")) - (file-names (directory-files substantial-directory all?))) - (with-cwd* - substantial-directory - (lambda () - (let ((files (if (or recursive? long? flag?) ; these are the flags for which we need the file-info - (map (lambda (file-name) - (cons file-name (file-info file-name #f))) - file-names) - (map (lambda (file-name) (cons file-name #f)) - file-names)))) - - (if (and (not long?) - columns?) - (ls-files-columns files flag? port) - (ls-files-column files long? flag? port)) - - (if recursive? - (let ((directories - (map (lambda (file) (car file)) - (filter (lambda (file) - (eq? (file-info:type (cdr file)) 'directory)) - files)))) - (if (not (null? directories)) - (begin - (ls-newline port) - (real-ls directories directory - all? recursive? long? directory? flag? columns? - port)))))))))) - -(define *width* 79) - -(define (ls-files-columns files flag? port) - (let* ((max-file-name-width - (if (null? files) - 0 - (apply max (map (lambda (file) (string-length (car file))) files)))) - (max-file-name-width - (if flag? - (+ 1 max-file-name-width) - max-file-name-width)) - - (column-width (+ 2 max-file-name-width)) - - (columns (quotient *width* - column-width)) - (columns (if (zero? columns) - 1 - columns)) - - (number-of-files (length files)) - (rows (quotient (+ number-of-files (- columns 1)) - columns)) - - (tails - (do ((column 0 (+ 1 column)) - (tails (make-vector columns))) - ((= column columns) - tails) - (vector-set! tails column - (list-tail-or-null files (* rows column)))))) - - (do ((row 0 (+ 1 row))) - ((= row rows)) - (do ((column 0 (+ 1 column))) - ((= column columns)) - (let ((tail (vector-ref tails column))) - (if (not (null? tail)) - (let* ((file (car tail)) - (width (display-file file flag? port))) - (display-spaces (- column-width width) port) - (vector-set! tails column (cdr tail)))))) - (ls-newline port)))) - -(define (list-tail-or-null list index) - (let loop ((list list) (index index)) - (cond - ((null? list) list) - ((zero? index) list) - (else (loop (cdr list) (- index 1)))))) - -(define (ls-files-column files long? flag? port) - (for-each - (lambda (file) - (ls-file file long? flag? port)) - files)) - -(define (ls-file file long? flag? port) - (if long? - (ls-file-long file flag? port) - (ls-file-short file flag? port))) - -(define (ls-file-short file flag? port) - (display-file file flag? port) - (ls-newline port)) - -(define (ls-file-long file flag? port) - (let ((info (cdr file))) - (display-permissions info port) - (display-decimal-justified (file-info:nlinks info) 4 port) - (write-char #\space port) - (let* ((uid (file-info:uid info)) - (user-name - (call-with-current-continuation - (lambda (escape) - (with-handler - (lambda (condition more) - (escape (number->string uid))) - (lambda () - (user-info:name (user-info uid)))))))) - (display-padded user-name 9 port)) - (let* ((gid (file-info:gid info)) - (group-name - (call-with-current-continuation - (lambda (escape) - (with-handler - (lambda (condition more) - (escape (number->string gid))) - (lambda () - (group-info:name (group-info gid)))))))) - (display-padded group-name 9 port)) - (display-decimal-justified (file-info:size info) 7 port) - (write-char #\space port) - (display-time (file-info:mtime info) port) - (write-char #\space port) - (display-file file flag? port) - (if (eq? (file-info:type info) 'symlink) - (begin - (display " -> " port) - (display (read-symlink (car file)) port))) - (ls-newline port))) - -(define *year-seconds* (* 365 24 60 60)) - -(define (display-time the-time port) - (let ((time-difference (abs (- (time) the-time))) - (date (date the-time 0))) - (if (< time-difference *year-seconds*) - (display (format-date "~b ~d ~H:~M" date) port) - (display (format-date "~b ~d ~Y " date) port)))) - -(define (display-file file flag? port) - (let ((file-name (car file))) - (display file-name port) - (if (maybe-display-flag (cdr file) flag? port) - (+ 1 (string-length file-name)) - (string-length file-name)))) - -(define (maybe-display-flag info flag? port) - (and flag? - (begin - (cond - ((eq? (file-info:type info) 'directory) - (write-char #\/ port)) - ((eq? (file-info:type info) 'symlink) - (write-char #\@ port)) - ; 'executable: bits 0, 3 or 6 are set: - ; that means, 'AND' with 1+8+64=73 results in a nonzero-value - ; note: there is no distinction between user's, group's and other's permissions - ; (as the real GNU-ls does not) - ((not (zero? (bitwise-and (file-info:mode info) 73))) - (write-char #\* port)) - ((eq? (file-info:type info) 'socket) - (write-char #\= port)) - ((eq? (file-info:type info) 'fifo) - (write-char #\| port))) - #t))) - -(define (display-permissions info port) - (case (file-info:type info) - ((directory) - (write-char #\d port)) - ((symlink) - (write-char #\l port)) - ((fifo) - (write-char #\p port)) - (else - (write-char #\- port))) - (let ((mode (file-info:mode info)) - (bit 8)) - (for-each - (lambda (id) - (if (not (zero? (bitwise-and (arithmetic-shift 1 bit) - mode))) - (write-char id port) - (write-char #\- port)) - (set! bit (- bit 1))) - '(#\r #\w #\x #\r #\w #\x #\r #\w #\x)))) - -(define (display-decimal-justified number width port) - (display-justified (number->string number) width port)) - -(define (display-justified string width port) - (let ((length (string-length string))) - (if (< length width) - (display-spaces (- width length) port)) - (display string port))) - -(define (display-padded string width port) - (let ((length (string-length string))) - (display string port) - (if (< length width) - (display-spaces (- width length) port)))) - -(define (display-spaces number port) - (do ((i 0 (+ 1 i))) - ((= i number)) - (write-char #\space port))) - -;; Convert Unix-style arguments to flags suitable for LS. - -(define (arguments->ls-flags args) - (let loop ((args args) (flags '())) - (if (null? args) - flags - (cond - ((argument->ls-flags (car args)) - => (lambda (new-flags) - (loop (cdr args) (append new-flags flags)))) - (else #f))))) - -(define (argument->ls-flags arg) - (let ((arg (if (symbol? arg) - (symbol->string arg) - arg))) - (if (or (string=? "" arg) - (not (char=? #\- (string-ref arg 0)))) - #f - (let loop ((chars (cdr (string->list arg))) (flags '())) - (cond - ((null? chars) - flags) - ((char->flag (car chars)) - => (lambda (flag) - (loop (cdr chars) (cons flag flags)))) - (else #f)))))) - -(define (char->flag char) - (case char - ((#\a) 'all) - ((#\R) 'recursive) - ((#\l) 'long) - ((#\d) 'directory) - ((#\F) 'flag) - ((#\C) 'columns) - (else #f))) - -(define (optional maybe-arg default-exp) - (cond - ((null? maybe-arg) default-exp) - ((null? (cdr maybe-arg)) (car maybe-arg)) - (else (error "too many optional arguments" maybe-arg)))) - -(define (ls-newline port) - (if (fluid ls-crlf?) - (write-crlf port) - (newline port))) \ No newline at end of file diff --git a/netrc.scm b/netrc.scm deleted file mode 100644 index 1736ad0..0000000 --- a/netrc.scm +++ /dev/null @@ -1,393 +0,0 @@ -;;; netrc.scm -- parse authentication information contained in ~/.netrc -;; -;; $Id: netrc.scm,v 1.7 2002/04/04 23:22:28 interp Exp $ -;; -;; Please send suggestions and bug reports to - - - -;;; Overview ===================================================== -;; -;; On Unix systems the ~/.netrc file (in the user's home directory) -;; may contain information allowing automatic login to remote hosts. -;; The format of the file is defined in the ftp(1) manual page. -;; Example lines are -;; -;; machine ondine.cict.fr login marsden password secret -;; default login anonymous password user@site -;; -;; The ~/.netrc file should be protected by appropriate permissions, -;; and (like /usr/bin/ftp) this library will refuse to read the file if -;; it is badly protected. (unlike /usr/bin/ftp this library will always -;; refuse to read the file -- /usr/bin/ftp refuses it only if the password -;; is given for a non-default account). Appropriate permissions are set -;; if only the user has permissions on the file. -;; -;; Note following restrictions / differences: -;; * The macdef statement (defining macros) is not supported. -;; * The settings for one machine must be on a single line. -;; * The is no error proof while reading the file. -;; * default need not be the last line of the netrc-file - - - -;;; Entry points ======================================================= -;; -;; What you probably want, is to read out the default netrc-file. Do the -;; following: -;; -;; (let ((netrc-record (netrc:parse))) -;; (netrc:lookup netrc-record "name of the machine")) -;; -;; and you will receive three values: login-name, password and account-name. -;; If you only want the login-name or the password, use netrc:lookup-login -;; or netrc:lookup-password resp. -;; -;; You will get either the login / password for the specified machine, -;; or a default login / password if the machine is unknown. -;; -;; -;; (user-mail-address) -> string -;; Calculate the user's email address, as per the Emacs function of -;; the same name. Will take into account the environment variable -;; REPLYTO, if set. Otherwise the mail-address will look like -;; user@hostname. -;; -;; (netrc:parse [filename [fallback-password [fallback-login]]]) -;; -> netrc-record -;; * parses the netrc file and returns a netrc-record, containing all -;; necessary information for the following procedures. -;; * FILENAME defaults to "~/.netrc" -;; FALLBACK-PASSWORD defaults to the result of (user-mail-address) -;; FALLBACK-LOGIN defaults to "anonymous" -;; * if the netrc file does not provide a default password or a default -;; login (stated by the "default" statement), FALLBACK-PASSWORD and -;; FALLBACK-LOGIN will be used as default password or login, respectively. -;; (thus, user-mail-address is only called if the netrc file does not -;; contain a default specification) -;; * if the netrc file does not exist, a netrc-record filled with -;; default values is returned. -;; * if the netrc file does not have the correct permissions, a message is -;; printed to current error port and a netrc-record filled with default -;; values is returned. -;; -;; (netrc:try-parse filename fallback-password fallback-login) -> netrc-record -;; parses the netrc file and returns a netrc-record, containing all -;; necessary information for the following procedures. -;; if there is no file called FILENAME, the according error will be raised -;; if the specified file does not have the correct permissions set, -;; a netrc-refuse-warning will be signalled. -;; so if you don't like the error handling of netrc:parse, use -;; netrc:try-parse and catch the signalled conditions. -;; -;; (netrc:lookup netrc-record machine [default?]) -> string x string x string -;; Return the login,password,account information for MACHINE -;; specified by the netrc file. -;; If DEFAULT? is #t, default values are returned if no such -;; MACHINE is specified in the netrc file. Otherwise, #f,#f,#f -;; is returned -;; -;; (netrc:lookup-password netrc-record machine [default?]) -> string -;; Return the password information for MACHINE specified by the -;; netrc file. -;; If DEFAULT? is #t, the default password is returned if no such -;; MACHINE is specified. Otherwise, #f is returned. -;; -;; (netrc:lookup-login netrc-record machine [default?]) -> string -;; Return the login information for MACHINE specified by the -;; netrc file. -;; If DEFAULT? is #t, the default login is returned if no such -;; MACHINE is specified. Otherwise, #f is returned. -;; -;; (netrc:default-login netrc-record) -> string -;; Return the default login specified by the netrc file or "anonymous" -;; -;; (netrc:default-password netrc-record) -> string -;; Return the default password specified by the netrc file or -;; the mail-addres (result of (user-mail-address)) - - - -;;; Related work ======================================================== -;; -;; * Graham Barr has written a similar library for Perl, called -;; Netrc.pm -;; -;; * ange-ftp.el (transparent remote file access for Emacs) parses the -;; user's netrc file - - -;;; Portability ================================================== -;; -;; getenv, scsh file primitives, regexp code, format -;; define-record, ecm-utilities - - -;;; Desirable things ============================================= -;; -;; * Remove restrictions (as stated in 'Overview') and behave like -;; /usr/bin/ftp behaves -;; * perhaps: adding case-insensitivity (for host names) -;; * perhaps: better record-disclosers for netrc-entry- and netrc-records - - -; return the user's mail address, either specified by the environment -; variable REPLYTO or "user@hostname". -(define (user-mail-address) - (or (getenv "REPLYTO") - (string-append (user-login-name) "@" (system-fqdn)))) - - -; looks up the desired machine in a netrc-record -; if the machine is found in the entries-section -; following three values are returned: login, password and account -; if the machine is not found in the entries-section -; the behavior depends on lookup-default? which defaults to #t: -; if lookup-default? is #t -; following three values are returned: default-login default-password #f -; otherwise #f #f #f is returned. -(define (netrc:lookup netrc-record machine . lookup-default?) - (let-optionals lookup-default? - ((lookup-default? #t)) - (let ((record (find-record netrc-record machine))) - (if record - (values (netrc-entry:login record) - (netrc-entry:password record) - (netrc-entry:account record)) - (if lookup-default? - (values (netrc:default-login netrc-record) - (netrc:default-password netrc-record) - #f) - (values #f #f #f)))))) - -; does the same as netrc:lookup, but returns only the password (or #f) -(define (netrc:lookup-password netrc-record machine . lookup-default?) - (let-optionals lookup-default? - ((lookup-default? #t)) - (let ((record (find-record netrc-record machine))) - (if record - (netrc-entry:password record) - (and lookup-default? - (netrc:default-password netrc-record)))))) - -; does the same as netrc:lookup, but returns only the login (or #f) -(define (netrc:lookup-login netrc-record machine . lookup-default?) - (let-optionals lookup-default? - ((lookup-default? #t)) - (let ((record (find-record netrc-record machine))) - (if record - (netrc-entry:login record) - (and lookup-default? - (netrc:default-login netrc-record)))))) - -; does the work for netrc:parse -; file-name has to be resolved -(define (netrc:try-parse file-name default-password default-login) - (netrc:check-permissions file-name) - (let ((fd (open-input-file file-name)) - (netrc-record (make-netrc '() default-password default-login file-name))) - (for-each-line (parse-line netrc-record) fd))) - -; parses the netrc-file -; expected arguments: filename default-password default-login -; filename: filename of the .netrc-file (defaults to ~/.netrc) -; default-password: default password for any not specified machine -; defaults to (user-mail-address) -; default password in netrc-file overwrites this setting -; default-login: default login name for any not specified machine -; defaults to "anonymous" -; default login in netrc-file overwrites this setting -; * (default-login is expected after default-password as users usually want -; to change the default-password (to something else than their mail-address) -; rather than the login-name)(define (netrc:parse . args) -; * if the given file does not exist or it has the wrong permissions, -; than a default netrc-record is returned -; * if you don't want expected errors to be captured, use netrc:try-parse; -; note that you have to resolve the file-name on your own -(define-condition-type 'netrc-refuse '(warning)) -(define netrc-refuse? (condition-predicate 'netrc-refuse)) - -(define (netrc:parse . args) - (let-optionals - args ((file-name "~/.netrc") - (default-password #f) ; both ... - (default-login #f)) ; ... are set if netrc-file does - ; not provide default-values - (let* ((file-name (resolve-file-name file-name)) - (local-default-login (lambda () "anonymous")) - (local-default-password (lambda () (user-mail-address))) - (local-default-netrc-record - (lambda () - (make-netrc '() - (or default-login (local-default-login)) - (or default-password (local-default-password)) - #f)))) -; i know, this double-handler sucks; has anyone a better idea? - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (error more) - (if (netrc-refuse? error) - (format (current-error-port) - "netrc: Warning: ~a~%" - (car (condition-stuff error))) - (format (current-error-port) - "netrc: Warning: Unexpected error encountered: ~s~%" - error)) - (exit (local-default-netrc-record))) - (lambda () - (with-errno-handler* - (lambda (errno packet) - (if (= errno errno/noent) - (format (current-error-port) - "netrc: Warning: no such file or directory: ~a~%" - file-name) - (format (current-error-port) - "netrc: Warning: Error accessing file ~s~%" - file-name)) - (exit (local-default-netrc-record))) - (lambda () - (let ((netrc-record - (netrc:try-parse file-name default-password default-login))) - ; If we get a netrc-record, we return it after - ; checking default login and default password settings. - ; Otherwise, we return the default record with - ; file-name stored. - ; This is sub-optimal, as we may throw away badly - ; structured .netrc-files silently. We need an error - ; checking mechanism. - (if (netrc? netrc-record) - (begin - (if (eq? (netrc:default-login netrc-record) #f) - (set-netrc:default-login (local-default-login))) - (if (eq? (netrc:default-password netrc-record) #f) - (set-netrc:default-password (local-default-password))) - netrc-record) - (let ((default-netrc-record (local-default-netrc-record))) - (set-netrc:file-name default-netrc-record file-name) - default-netrc-record)))))))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; nothing exported below -;; except -;; netrc:default-password -;; netrc:default-login - -(define-record netrc-entry - machine - login - password - account) - -(define-record netrc - entries ; list of netrc-entrys - default-login ; default-values (either library-default or netrc-file-default) - default-password - file-name) ; debug-purpose - - -(define-record-discloser type/netrc-entry - (lambda (netrc-entry) - (list 'netrc-entry))) ; perhaps something else later on - -(define-record-discloser type/netrc - (lambda (netrc) - (list 'netrc))) ; perhaps something else later on - -; finds a record in the entries-list of a netrc-record -; matching the given machine -; returns the netrc-entry-record if found, otherwise #f -(define (find-record netrc-record machine) - (find-first (lambda (rec) - (and (equal? (netrc-entry:machine rec) machine) - rec)) - (netrc:entries netrc-record))) - - -;; raise error if any permissions are set for group or others. -(define (netrc:check-permissions file-name) - (let ((perms (- (file-mode file-name) 32768))) - (if (positive? (bitwise-and #b000111111 perms)) - (signal 'netrc-refuse - (format #f - "Not parsing ~s (netrc file); dangerous permissions." - file-name))))) - -; tries to match target on line and returns the first group, -; or #f if there is no match -(define (try-match target line) - (let ((match (string-match target line))) - (and match - (match:substring match 1)))) - -; parses the default line of the netrc-file -(define (parse-default netrc-record line) - (let ((login (try-match "login[ \t]+([^ \t]+)" line)) - (password (try-match "password[ \t]+([^ \t]+)" line))) - (if login - (set-netrc:default-login netrc-record login)) - (if password - (set-netrc:default-password netrc-record password)) - netrc-record)) - -; parses a line of the netrc-file -(define (parse-line netrc-record) - (lambda (line) - (cond ((string-match "default" line) - (parse-default netrc-record line)) - (else - (let ((machine (try-match "machine[ \t]+([^ \t]+)" line)) - (login (try-match "login[ \t]+([^ \t]+)" line)) - (password (try-match "password[ \t]+([^ \t]+)" line)) - (account (try-match "account[ \t]+([^ \t]+)" line))) - (if (or machine login password account) - (add netrc-record machine login password account) - netrc-record)))))) ; return record on empty / wrong lines -; (This is a workaround. we should give a warning on malicious .netrc -; files. As we do not have an error checking system installed yet, we -; skip these lines silently.) - -; adds machine login password account stored in a netrc-entry-record -; to the entries-list of a netrc-record -(define (add netrc-record machine login password account) - (set-netrc:entries netrc-record - (cons (make-netrc-entry machine login password account) - (netrc:entries netrc-record))) - netrc-record) - -;; for testing -(define (netrc:dump netrc-record) - (format #t "~%--- Dumping ~s contents ---" (netrc:file-name netrc-record)) - (for-each (lambda (rec) - (format #t "~% machine ~a login ~a password ~a account ~a" - (netrc-entry:machine rec) - (netrc-entry:login rec) - (netrc-entry:password rec) - (netrc-entry:account rec))) - (netrc:entries netrc-record)) - (format #t "~% default login: ~s" (netrc:default-login netrc-record)) - (format #t "~% default password: ~s" (netrc:default-password netrc-record)) - (format #t "~%--- End of ~s contents ---~%" (netrc:file-name netrc-record))) - - -; runs proc for each line of fd (line is argument to proc) -; returns either nothing, if the fd had no line -; or the value returned by proc called on the last line -(define (for-each-line proc fd) - (let ((line (read-line fd))) - (if (not (eof-object? line)) - (let loop ((last-result (proc line))) - (let ((line (read-line fd))) - (if (not (eof-object? line)) - (loop (proc line)) - last-result)))))) - -; finds first element in l for which pred doesn't return #f -; returns either #f (no such element found) -; or the result of the last call to pred -(define (find-first pred l) - (if (null? l) #f - (or (pred (car l)) - (find-first pred (cdr l))))) - -;; EOF diff --git a/nettime-obsolete.scm b/nettime-obsolete.scm deleted file mode 100644 index 01b9a92..0000000 --- a/nettime-obsolete.scm +++ /dev/null @@ -1,6 +0,0 @@ -; maps obsolete nettime-procedure names to new nettime procedure names -; by Andreas Bernauer (2002) - -(define net:time net-time) -(define net:daytime net-daytime) - diff --git a/nettime.scm b/nettime.scm deleted file mode 100644 index 6ad772f..0000000 --- a/nettime.scm +++ /dev/null @@ -1,76 +0,0 @@ -;;; nettime.scm -- obtain the time on remote machines -;; -;; $Id: nettime.scm,v 1.3 2002/05/12 05:32:28 interp Exp $ -;; -;; Please send suggestions and bug reports to - - - -;;; Overview ======================================================== -;; -;; Most Unix hosts provide a Daytime service which sends the current -;; date and time as a human-readable character string. The daytime -;; service is typically served on port 13 as both TCP and UDP. -;; -;; The Time protocol provides a site-independent, machine readable -;; date and time. A "time" consists of the number of seconds since -;; midnight on 1st January 1900. The Time service is typically served -;; on port 37 as TCP and UDP. The idea is that you can confirm your -;; system's idea of the time by polling several independent sites on -;; the network. - - -;;; Related work ====================================================== -;; -;; * Time.pm is a Perl module by Graham Barr -;; * rfc868 describes the Time protocol -;; * rfc867 describes the Daytime protocol in all its glory -;; * for a genuinely useful protocol look at the Network Time Protocol -;; defined in rfc1305, which allows for the synchronization of clocks -;; on networked computers. - - - -;; args host protocol, where host may be an IP number or a fqdn. we -;; subtract 70 years' worth of seconds at the end, since the time -;; protocol returns the number of seconds since 1900, whereas Unix -;; time is since 1970. -(define (net-time host tcp/udp) - (let* ((hst-info (host-info host)) - (srvc-info (service-info "time" "tcp")) - (sock (socket-connect protocol-family/internet - tcp/udp - (host-info:name hst-info) - (service-info:port srvc-info))) - (result (read-integer (socket:inport sock)))) - (close-socket sock) - (- result 2208988800))) - - -(define (net-daytime host tcp/udp) - (let* ((hst-info (host-info host)) - (srvc-info (service-info "daytime" "tcp")) - (sock (socket-connect protocol-family/internet - tcp/udp - (host-info:name hst-info) - (service-info:port srvc-info))) - (result (read-string 20 (socket:inport sock)))) - (close-socket sock) - result)) - - -;; read 4 bytes from fd and build an integer from them -(define (read-integer fd) - (let loop ((accum 0) - (remaining 4)) - (if (zero? remaining) - accum - (loop (+ (arithmetic-shift accum 8) (read-byte fd)) - (- remaining 1))))) - -;; what about EOF?? -(define (read-byte fd) - (char->ascii (read-char fd))) - - -;; EOF diff --git a/parse-forms.scm b/parse-forms.scm deleted file mode 100644 index 46f99c8..0000000 --- a/parse-forms.scm +++ /dev/null @@ -1,67 +0,0 @@ -;;; Code to parse information submitted from HTML forms. -*- Scheme -*- -;;; Copyright (c) 1995 by Olin Shivers. - -;;; See http://www.w3.org/hypertext/WWW/MarkUp/html-spec/html-spec_toc.html - -;;; Imports and non-R4RS'isms -;;; string-index (string srfi) -;;; let-optionals (let-opt package) -;;; receive (Multiple-value return) -;;; unescape-uri -;;; map-string (strings package) -;;; ? (cond) - -;;; About HTML forms -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; The form's field data are turned into a single string, of the form -;;; The form's field data are turned into a single string, of the form -;;; name=val&name=val -;;; where the and parts are URI encoded to hide their -;;; &, =, and + chars, among other things. After URI encoding, the -;;; space chars are converted to + chars, just for fun. It is important -;;; to encode the spaces this way, because the perfectly general %xx escape -;;; mechanism might be insufficiently confusing. This variant encoding is -;;; called "form-url encoding." -;;; -;;; If the form's method is POST, -;;; Browser sends the form's field data in the entity block, e.g., -;;; "button=on&ans=yes". The request's Content-type: is application/ -;;; x-www-form-urlencoded, and the request's Content-length: is the -;;; number of bytes in the form data. -;;; -;;; If the form's method is GET, -;;; Browser sends the form's field data in the URL's part. -;;; (So the server will pass to the CGI script as $QUERY_STRING, -;;; and perhaps also on in argv[]). -;;; -;;; In either case, the data is "form-url encoded" (as described above). - -;;; Form-query parsing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Parse "foo=x&bar=y" into (("foo" . "x") ("bar" . "y")) -;;; Substrings are plus-decoded and then URI-decoded. This implementation is -;;; slightly sleazy as it will successfully parse a string like "a&b=c&d=f" -;;; into (("a&b" . "c") ("d" . "f")) without a complaint. - -(define (parse-html-form-query q) - (let ((qlen (string-length q))) - (let recur ((i 0)) - (cond - ((>= i qlen) '()) - ((string-index q #\= i) => - (lambda (j) - (let ((k (or (string-index q #\& j) qlen))) - (cons (cons (unescape-uri+ q i j) - (unescape-uri+ q (+ j 1) k)) - (recur (+ k 1)))))) - (else '()))))) ; BOGUS STRING -- Issue a warning. - - -;;; Map plus characters to spaces, then do URI decoding. -(define (unescape-uri+ s . maybe-start/end) - (let-optionals maybe-start/end ((start 0) - (end (string-length s))) - (unescape-uri (string-map (lambda (c) (if (char=? c #\+) #\space c)) - (if (and (zero? start) - (= end (string-length s))) - s ; Gratuitous optimisation. - (substring s start end)))))) diff --git a/pop3-obsolete.scm b/pop3-obsolete.scm deleted file mode 100644 index b866f72..0000000 --- a/pop3-obsolete.scm +++ /dev/null @@ -1,12 +0,0 @@ -; maps obsolete pop3-procedure names to new pop3 procedure names -; by Andreas Bernauer (2002) - -(define pop3:connect pop3-connect) -(define pop3:login pop3-login) -(define pop3:stat pop3-stat) -(define pop3:get pop3-get) -(define pop3:headers pop3-headers) -(define pop3:last pop3-last) -(define pop3:delete pop3-delete) -(define pop3:reset pop3-reset) -(define pop3:quit pop3-quit) diff --git a/pop3.scm b/pop3.scm deleted file mode 100644 index b231e63..0000000 --- a/pop3.scm +++ /dev/null @@ -1,351 +0,0 @@ -;;; POP3.scm --- implement the POP3 maildrop protocol in the Scheme Shell -;; -;; $Id: pop3.scm,v 1.5 2002/05/12 05:53:44 interp Exp $ -;; -;; Please send suggestions and bug reports to - - -;;; Overview ============================================================== -;; -;; The POP3 protocol allows access to email on a maildrop server. It -;; is often used in configurations where users connect from a client -;; machine which doesn't have a permanent network connection or isn't -;; always turned on, situations which make local SMTP delivery -;; impossible. It is the most common form of email access provided by -;; Internet Service Providers. -;; -;; Two types of authentication are commonly used. The first, most -;; basic type involves sending a user's password in clear over the -;; network, and should be avoided. Unfortunately many POP3 clients -;; only implement this basic authentication. The digest authentication -;; system involves the server sending the client a "challenge" token; -;; the client encodes this token with the pass phrase and sends the -;; coded information to the server. This method avoids sending -;; sensitive information over the network. -;; -;; Once connected, a client may request information about the number -;; and size of the messages waiting on the server, download selected -;; messages (either their headers or the entire content), and delete -;; selected messages. - - -;;; Entry points ======================================================= -;; -;; (pop3-connect [host logfile]) -> connection -;; Connect to the maildrop server named HOST. Optionally log the -;; conversation with the server to LOGFILE, which will be appended -;; to if it exists, and created otherwise. The environment variable -;; MAILHOST, if set, will override the value of HOST. -;; -;; (pop3-login connection [login password]) -> status -;; Log in to the mailhost. If a login and password are not -;; provided, they are first searched for in the user's ~/.netrc -;; file. USER/PASS authentication will be tried first, and if this -;; fails, APOP authentication will be tried. -;; -;; (pop3-login/APOP connection login password) -> status -;; Log in to the mailhost using APOP authentication. -;; -;; (pop3-stat connection) -> integer x integer -;; Return the number of messages and the number of bytes waiting in -;; the maildrop. -;; -;; (pop3-get connection msgid) -> status -;; Download message number MSGID from the mailhost. MSGID must be -;; positive and less than the number of messages returned by the -;; pop3-stat call. The message contents are sent to -;; (current-output-port). -;; -;; (pop3-headers connection msgid) -> status -;; Download the headers of message number MSGID. The data is sent -;; to (current-output-port). -;; -;; (pop3-last connection) -> integer -;; Return the highest accessed message-id number for the current -;; session. This isn't in the RFC, but seems to be supported by -;; several servers. -;; -;; (pop3-delete connection msgid) -> status -;; Mark message number MSGID for deletion. The message will not be -;; deleted until the client logs out. -;; -;; (pop3-reset connection) -> status -;; Any messages which have been marked for deletion are unmarked. -;; -;; (pop3-quit connection) -> status -;; Close the connection with the mailhost. - - - -;;; Portability ====================================================== -;; -;; define-record -;; socket, regexp -;; signals/handlers - - -;;; Related work ===================================================== -;; -;; * Emacs is distributed with a C program called movemail which can -;; be compiled with support for the POP protocol. There is also an -;; Emacs Lisp library called pop3.el by Richard Pieri which includes -;; APOP support. -;; -;; * Shriram Krishnamurth has written a POP3 library for MzScheme (as -;; well as support for the NNTP protocol, for SMTP, ...). -;; -;; * Siod (a small-footprint Scheme implementation by George Carette) -;; includes support for the POP3 protocol. -;; -;; * rfc1939 describes the POP3 protocol. - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Communication is initiated by the client. The server responds to -;; each request with a status indicator and an explanatory message. -;; The client starts off by opening a connection to a well known port -;; on the server machine (typically TCP 110, or 109 on some broken -;; systems). Messages sent to the server are of the form -;; -;; CMD [ arg ] -;; -;; Replies from the server are of the form -;; -;; status [ Informative message ] -;; -;; where status is either "+OK" or "-ERR". If the server is sending -;; data (the contents of a message for example), it marks the end of -;; the data by a line consisting only of a decimal point (thus the -;; bytes to look out for are .. Any lines in the data -;; starting with a . have an additional . added to the beginning, to -;; avoid the client thinking that the line marks the end of the -;; message. The client should therefore replace double decimal points -;; at the beginning of a line by a single decimal point. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;: [host x logfile] -> connection -(define (pop3-connect . args) - (let* ((host (or (getenv "MAILHOST") - (safe-first args))) - (logfile (safe-second args)) - (LOG (and logfile - (open-output-file logfile - (if (file-exists? logfile) - (bitwise-ior open/write open/append) - (bitwise-ior open/write open/create)) - #o600))) - (hst-info (host-info host)) - (hostname (host-info:name hst-info)) - (srvc-info (service-info "pop3" "tcp")) - (sock (socket-connect protocol-family/internet - socket-type/stream - hostname - (service-info:port srvc-info))) - (connection (make-pop3-connection hostname - sock - LOG "" "" #f #f))) - (pop3-log connection - (format #f "~%-- ~a: opened POP3 connection to ~a" - ;; (date->string (date)) - "Dummy date" ; (format-time-zone) is broken in v0.5.1 - hostname)) - - ;; read the challenge the server sends in its welcome banner - (let* ((banner (pop3-read-response connection)) - (match (regexp-search (rx (posix-string "\\+OK .* (<[^>]+>)")) banner)) - (challenge (and match (match:substring match 1)))) - (set-pop3-connection:challenge connection challenge)) - - connection)) - - -;; first try standard USER/PASS authentication, and switch to APOP -;; authentication if the server prefers. -;;: [string x string] -> status -(define (pop3-login connection . args) - (let* ((netrc (and (< (length args) 2) (netrc:parse))) - (login (or (safe-first args) - (netrc:lookup-login netrc (pop3-connection:host-name connection) #f) - (call-error "must provide a login" pop3-login args))) - (password (or (safe-second args) - (netrc:lookup-password netrc (pop3-connection:host-name connection) #f) - (call-error "must provide a password" pop3-login args)))) - (with-handler - (lambda (result punt) - (if (-ERR? result) - (if (pop3-connection:challenge connection) - (pop3-login/APOP connection login password) - (error "login failed")))) - (lambda () - (pop3-send-command connection (format #f "USER ~a" login)) - (pop3-send-command connection (format #f "PASS ~a" password)) - (set-pop3-connection:login connection login) - (set-pop3-connection:password connection password) - (set-pop3-connection:state connection 'connected))))) - - -;; Login to the server using APOP authentication (no cleartext -;; passwords are sent over the network). The server appends a token to -;; its welcome message, which is built from the server's fully -;; qualified domain name and a unique serial number. The client -;; concatenates this token and the pass phrase and applies the MD5 -;; digest algorithm (a one-way hash) to produce a digest. The user -;; name and the digest are sent to the server to authenticate the -;; user. The following example comes from the RFC: -;; -;; S: +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us> -;; C: APOP mrose c4c9334bac560ecc979e58001b3e22fb -;; S: +OK maildrop has 1 message (369 octets) -;; -;; In this example, the shared secret is the string `tan- -;; staaf'. Hence, the MD5 algorithm is applied to the string -;; -;; <1896.697170952@dbc.mtview.ca.us>tanstaaf -;; -;; which produces a digest value of -;; -;; c4c9334bac560ecc979e58001b3e22fb -;; -;;: connection x string x string -> status -(define (pop3-login/APOP connection login password) - (let* ((key (string-append (pop3-connection:challenge connection) - password)) - (digest (md5-digest key)) - (status (pop3-send-command connection - (format #f "APOP ~a ~a" login digest)))) - (set-pop3-connection:login connection login) - (set-pop3-connection:password connection password) - (set-pop3-connection:state connection 'connected) - status)) - - -;; return number of messages and number of bytes waiting at the maildrop -;;: connection -> integer x integer -(define (pop3-stat connection) - (pop3-check-transaction-state connection 'pop3-stat) - (let* ((response (pop3-send-command connection "STAT")) - (match (regexp-search (rx (posix-string "([0-9]+) ([0-9]+)")) response))) - (values (string->number (match:substring match 1)) - (string->number (match:substring match 2))))) - -;; dump the message number MSGID to (current-output-port) -;;: connection x integer -> status -(define (pop3-get connection msgid) - (pop3-check-transaction-state connection 'pop3-get) - (let ((status (pop3-send-command connection (format #f "RETR ~a" msgid)))) - (pop3-dump (socket:inport (pop3-connection:command-socket connection))) - status)) - -;;: connection x integer -> status -(define (pop3-headers connection msgid) - (pop3-check-transaction-state connection 'pop3-headers) - (let ((status (pop3-send-command connection (format #f "TOP ~a 0" msgid)))) - (pop3-dump (socket:inport (pop3-connection:command-socket connection))) - status)) - -;; Return highest accessed message-id number for the session. This -;; ain't in the RFC, but seems to be supported by several servers. -;;: connection -> integer -(define (pop3-last connection) - (pop3-check-transaction-state connection 'pop3-last) - (let ((response (pop3-send-command connection "LAST"))) - (string->number (car ((infix-splitter) response))))) - -;; mark the message number MSGID for deletion. Note that the messages -;; are not truly deleted until the QUIT command is sent, and messages -;; can be undeleted using the RSET command. -;;: connection x integer -> status -(define (pop3-delete connection msgid) - (pop3-check-transaction-state connection 'pop3-delete) - (pop3-send-command connection (format #f "DELE ~a" msgid))) - - -;; any messages which have been marked for deletion are unmarked -;;: connection -> status -(define (pop3-reset connection) - (pop3-check-transaction-state connection 'pop3-reset) - (pop3-send-command connection "RSET")) - -;;: connection -> status -(define (pop3-quit connection) - (pop3-check-transaction-state connection 'pop3-quit) - (let ((status (pop3-send-command connection "QUIT"))) - (close-socket (pop3-connection:command-socket connection)) - status)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Nothing exported below. - -(define-record pop3-connection - host-name - command-socket - logfd - login - password - challenge - state) - -;; cf /usr/local/src/scheme48-0.49/scheme/rts/condition.scm -(define-condition-type '-ERR '(error)) -(define -ERR? (condition-predicate '-ERR)) - - -(define (pop3-check-transaction-state connection caller) - (if (not (eq? (pop3-connection:state connection) 'connected)) - (call-error "not in transaction state" caller))) - -(define (pop3-read-response connection) - (let* ((sock (pop3-connection:command-socket connection)) - (IN (socket:inport sock)) - (line (read-line IN))) - (pop3-log connection (format #f "-> ~a" line)) - line)) - -;; this could perhaps be improved -(define (pop3-handle-response response command) - (let ((match (regexp-search (rx (posix-string "^\\+OK(.*)")) response))) - (if match - (match:substring match 1) - (let ((match2 (regexp-search (rx (posix-string "^-ERR(.*)")) response))) - (if match2 - (signal '-ERR (match:substring match2 1) command) - (signal '-ERR response command)))))) - - -(define (pop3-log connection line) - (let ((LOG (pop3-connection:logfd connection))) - (and LOG - (write-string line LOG) - (write-string "\n" LOG) - (force-output LOG)))) - -(define (pop3-send-command connection command) - (let* ((sock (pop3-connection:command-socket connection)) - (OUT (socket:outport sock))) - (write-string command OUT) - (write-crlf OUT) - (pop3-log connection (format #f "<- ~a" command)) - (pop3-handle-response (pop3-read-response connection) command))) - - -;; who will write this in Scheme? -(define (md5-digest str) - (car (run/strings (md5sum) (<< ,str)))) -; the name of the program differs among the distributions -; e.g. in FreeBSD it is called md5 - -(define (pop3-dump fd) - (let loop ((line (read-line fd))) - (cond ((and (not (eof-object? line)) - (not (equal? line ".\r"))) - (and (eq? 0 (string-index line #\.)) ; fix byte-stuffed lines - (eq? 1 (string-index line #\. 1)) - (set! line (substring line 1 (string-length line)))) - (write-string line) - (newline) - (loop (read-line fd)))))) - -;; EOF diff --git a/rate-limit.scm b/rate-limit.scm deleted file mode 100644 index 5a461c6..0000000 --- a/rate-limit.scm +++ /dev/null @@ -1,58 +0,0 @@ -;;; Rate limiting -*- Scheme -*- -;;; Copyright (c) 2002 by Mike Sperber. - -(define-record-type rate-limiter :rate-limiter - (really-make-rate-limiter simultaneous-requests - access-lock - block-lock - current-requests) - rate-limiter? - (simultaneous-requests rate-limiter-simultaneous-requests) - (access-lock rate-limiter-access-lock) - (block-lock rate-limiter-block-lock) - (current-requests rate-limiter-current-requests-unsafe - set-rate-limiter-current-requests!)) - -(define (make-rate-limiter simultaneous-requests) - (really-make-rate-limiter simultaneous-requests - (make-lock) - (make-lock) - 0)) - -(define (rate-limit-block rate-limiter) - (obtain-lock (rate-limiter-block-lock rate-limiter))) - -(define (rate-limit-open rate-limiter) - (obtain-lock (rate-limiter-access-lock rate-limiter)) - (let ((current-requests - (+ 1 (rate-limiter-current-requests-unsafe rate-limiter)))) - (set-rate-limiter-current-requests! rate-limiter - current-requests) - (if (>= current-requests - (rate-limiter-simultaneous-requests rate-limiter)) - (maybe-obtain-lock (rate-limiter-block-lock rate-limiter)) - (release-lock (rate-limiter-block-lock rate-limiter)))) - (release-lock (rate-limiter-access-lock rate-limiter))) - -(define (rate-limit-close rate-limiter) - (obtain-lock (rate-limiter-access-lock rate-limiter)) - (let ((current-requests - (- (rate-limiter-current-requests-unsafe rate-limiter) 1))) - (if (negative? current-requests) - (error "rate-limiter: too many close operations" - rate-limiter)) - (set-rate-limiter-current-requests! rate-limiter - current-requests) - (if (= current-requests - (- (rate-limiter-simultaneous-requests rate-limiter) - 1)) - ;; we just came back into range - (release-lock (rate-limiter-block-lock rate-limiter)))) - (release-lock (rate-limiter-access-lock rate-limiter))) - -(define (rate-limiter-current-requests rate-limiter) - (obtain-lock (rate-limiter-access-lock rate-limiter)) - (let ((current-requests - (rate-limiter-current-requests-unsafe rate-limiter))) - (release-lock (rate-limiter-access-lock rate-limiter)) - current-requests)) diff --git a/rfc822.scm b/rfc822.scm deleted file mode 100644 index 10d0868..0000000 --- a/rfc822.scm +++ /dev/null @@ -1,219 +0,0 @@ -;;; RFC 822 field-parsing code -*- Scheme -*- -;;; Copyright (c) 1995 by Olin Shivers. -;;; -;;; -;;; Imports and non-R4RS'isms -;;; string conversions -;;; read-crlf-line -;;; let-optionals, :optional -;;; receive values (MV return) -;;; "\r\n" in string for cr/lf -;;; ascii->char (defining the tab char) -;;; index -;;; string-join (reassembling body lines) -;;; error -;;; ? (COND) - -;;; RFC 822 is the "Standard for the format of ARPA Internet text messages" -;;; -- the document that essentially tells how the fields in email headers -;;; (e.g., the Subject: and To: fields) are formatted. This code is for -;;; parsing these headers. Here are two pointers to the document: -;;; Emacs/ange /ftp@ftp.internic.net:/rfc/rfc822.txt -;;; URL ftp://ftp.internic.net/rfc/rfc822.txt -;;; RFC 822 parsing is useful in other contexts as well -- the HTTP protocol -;;; uses it, and it tends to pop up here and there. -;;; -;;; RFC 822 header syntax has two levels: the general syntax for headers, -;;; and the syntax for specific headers. For example, once you have figured -;;; out which chunk of text is the To: line, there are more rules telling -;;; how to split the To: line up into a list of addresses. Another example: -;;; lines with dates, e.g., the Date: header, have a specific syntax for -;;; the time and date. -;;; -;;; This code currently *only* provides routines for parsing the gross -;;; structure -- splitting the message header into its distinct fields. -;;; It would be nice to provide the finer-detail parsers, too. You do it. -;;; -Olin - -;;; A note on line-terminators: -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Line-terminating sequences are always a drag, because there's no agreement -;;; on them -- the Net protocols and DOS use cr/lf; Unix uses lf; the Mac -;;; uses cr. One one hand, you'd like to use the code for all of the above, -;;; on the other, you'd also like to use the code for strict applications -;;; that need definitely not to recognise bare cr's or lf's as terminators. -;;; -;;; RFC 822 requires a cr/lf (carriage-return/line-feed) pair to terminate -;;; lines of text. On the other hand, careful perusal of the text shows up -;;; some ambiguities (there are maybe three or four of these, and I'm too -;;; lazy to write them all down). Furthermore, it is an unfortunate fact -;;; that many Unix apps separate lines of RFC 822 text with simple linefeeds -;;; (e.g., messages kept in /usr/spool/mail). As a result, this code takes a -;;; broad-minded view of line-terminators: lines can be terminated by either -;;; cr/lf or just lf, and either terminating sequence is trimmed. -;;; -;;; If you need stricter parsing, you can call the lower-level procedure -;;; %READ-RFC-822-FIELD and %READ-RFC822-HEADERS procs. They take the -;;; read-line procedure as an extra parameter. This means that you can -;;; pass in a procedure that recognises only cr/lf's, or only cr's (for a -;;; Mac app, perhaps), and you can determine whether or not the terminators -;;; get trimmed. However, your read-line procedure must indicate the -;;; header-terminating empty line by returning *either* the empty string or -;;; the two-char string cr/lf (or the EOF object). - -;;; (read-rfc822-field [port]) -;;; (%read-rfc822-field read-line port) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Read one field from the port, and return two values [NAME BODY]: -;;; - NAME Symbol such as 'subject or 'to. The field name is converted -;;; to a symbol using the Scheme implementation's preferred -;;; case. If the implementation reads symbols in a case-sensitive -;;; fashion (e.g., scsh), lowercase is used. This means you can -;;; compare these symbols to quoted constants using EQ?. When -;;; printing these field names out, it looks best if you capitalise -;;; them with (CAPITALIZE-STRING (SYMBOL->STRING FIELD-NAME)). -;;; - BODY List of strings which are the field's body, e.g. -;;; ("shivers@lcs.mit.edu"). Each list element is one line -;;; from the field's body, so if the field spreads out -;;; over three lines, then the body is a list of three -;;; strings. The terminating cr/lf's are trimmed from each -;;; string. A leading space or a leading horizontal tab -;;; is also trimmed, but one and only one. -;;; When there are no more fields -- EOF or a blank line has terminated the -;;; header section -- then the procedure returns [#f #f]. -;;; -;;; The %READ-RFC822-FIELD variant allows you to specify your own -;;; read-line procedure. The one used by READ-RFC822-FIELD terminates -;;; lines with either cr/lf or just lf, and it trims the terminator -;;; from the line. Your read-line procedure should trim the terminator -;;; of a line so an empty line is returned just as an empty string. - -(define htab (ascii->char 9)) - -;;; Convert to a symbol using the Scheme implementation's preferred case, -;;; so we can compare these things against quoted constants. -(define string->symbol-pref - (if (char=? #\a (string-ref (symbol->string 'a) 0)) ; Is it #\a or #\A? - (lambda (s) (string->symbol (string-map char-downcase s))) - (lambda (s) (string->symbol (string-map char-upcase s))))) - -(define (read-rfc822-field . maybe-port) - (let-optionals maybe-port ((port (current-input-port))) - (%read-rfc822-field read-crlf-line port))) - -(define (%read-rfc822-field read-line port) - (let ((line1 (read-line port))) - (if (or (eof-object? line1) - (zero? (string-length line1)) - (string=? line1 "\r\n")) ; In case read-line doesn't trim. - - (values #f #f) ; Blank line or EOF terminates header text. - - (cond - ((string-index line1 #\:) => ; Find the colon and - (lambda (colon) ; split out field name. - (let ((name (string->symbol-pref (substring line1 0 colon)))) - ;; Read in continuation lines. - (let lp ((lines (list (substring line1 - (+ colon 1) - (string-length line1))))) - (let ((c (peek-char port))) ; Could return EOF. -;;; RFC822: continuous lines has to start with a space or a htab - (if (or (eqv? c #\space) (eqv? c htab)) - (lp (cons (read-line port) lines)) - (values name (reverse lines)))))))) - (else (error "Illegal RFC 822 field syntax." line1)))))) ; No : - - -;;; (read-rfc822-headers [port]) -;;; (%read-rfc822-headers read-line port) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Read in and parse up a section of text that looks like the header portion -;;; of an RFC 822 message. Return an alist mapping a field name (a symbol -;;; such as 'date or 'subject) to a list of field bodies -- one for -;;; each occurence of the field in the header. So if there are five -;;; "Received-by:" fields in the header, the alist maps 'received-by -;;; to a five element list. Each body is in turn represented by a list -;;; of strings -- one for each line of the field. So a field spread across -;;; three lines would produce a three element body. -;;; -;;; The %READ-RFC822-HEADERS variant allows you to specify your own read-line -;;; procedure. See notes above for reasons why. - -(define (read-rfc822-headers . maybe-port) - (let-optionals maybe-port ((port (current-input-port))) - (%read-rfc822-headers read-crlf-line port))) - -(define (%read-rfc822-headers read-line port) - (let lp ((alist '())) - (receive (field val) (%read-rfc822-field read-line port) - (cond (field (cond ((assq field alist) => - (lambda (entry) - (set-cdr! entry (cons val (cdr entry))) - (lp alist))) - (else (lp (cons (list field val) alist))))) - - ;; We are done. Reverse the order of each entry and return. - (else (for-each (lambda (entry) - (set-cdr! entry (reverse (cdr entry)))) - alist) - alist))))) - -;;; (rejoin-header-lines alist [separator]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Takes a field alist such as is returned by READ-RFC822-HEADERS and -;;; returns an equivalent alist. Each body (string list) in the input alist -;;; is joined into a single list in the output alist. SEPARATOR is the -;;; string used to join these elements together; it defaults to a single -;;; space " ", but can usefully be "\n" or "\r\n". -;;; -;;; To rejoin a single body list, use scsh's STRING-JOIN procedure. - -(define (rejoin-header-lines alist . maybe-separator) - (let-optionals maybe-separator ((sep " ")) - (map (lambda (entry) - (cons (car entry) - (map (lambda (body) (string-join body sep)) - (cdr entry)))) - alist))) - - -;;; Given a set of RFC822 headers like this: -;;; From: shivers -;;; To: ziggy, -;;; newts -;;; To: gjs, tk -;;; -;;; We have the following definitions: -;;; (get-header-all hdrs 'to) -> ((" ziggy," " newts") (" gjs, tk")) -;;; - All entries, or #f -;;; (get-header-lines hdrs 'to) -> (" ziggy," " newts") -;;; - All lines of the first entry, or #f. -;;; (get-header hdrs 'to) -> "ziggy,\n newts" -;;; - First entry, with the lines joined together by newlines. - -(define (get-header-all headers name) - (let ((entry (assq name headers))) - (and entry (cdr entry)))) - -(define (get-header-lines headers name) - (let ((entry (assq name headers))) - (and entry - (pair? entry) - (cadr entry)))) - -(define (get-header headers name . maybe-sep) - (let ((entry (assq name headers))) - (and entry - (pair? entry) - (string-join (cadr entry) - (:optional maybe-sep "\n"))))) - - - -;;; Other desireable functionality -;;; - Unfolding long lines. -;;; - Lexing structured fields. -;;; - Unlexing structured fields into canonical form. -;;; - Parsing and unparsing dates. -;;; - Parsing and unparsing addresses. diff --git a/smtp.scm b/smtp.scm deleted file mode 100644 index fe13a72..0000000 --- a/smtp.scm +++ /dev/null @@ -1,606 +0,0 @@ -;;; SMTP client code -*- Scheme -*- -;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers. -;;; , -;;; -;;; See rfc821: /ftp@ftp.internic.net:/rfc/rfc821.txt - -;;; External dependencies and non-R4RS'isms -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; system-name user-login-name (for high-level SENDMAIL proc) -;;; receive values (MV return) -;;; write-string read-string/partial (scsh I/O procs) -;;; force-output -;;; scsh's socket module -;;; :optional -;;; error -;;; read-crlf-line write-crlf -;;; \n \r in strings (Not R5RS) - -;;; SMTP protocol procedures tend to return two values: -;;; - CODE The integer SMTP reply code returned by server for the transaction. -;;; - TEXT A list of strings -- the text messages tagged by the code. -;;; The text strings have the initial code numerals and the terminating -;;; cr/lf's stripped. Codes in the range [1,399] are sucess codes; codes -;;; in the range [400,599] are error codes; codes >= 600 are not part -;;; of the official SMTP spec. This module uses codes >= 600 to indicate -;;; extra-protocol errors. There are two of these: -;;; - 600 Server reply could not be parsed. -;;; The server sent back some sort of incomprehensible garbage reply. -;;; - 621 Premature EOF while reading server reply. -;;; The server shut down in the middle of a reply. -;;; A list of the official protocol return codes is appended at the end of -;;; this file. - -;;; These little cover functions are trivial packagings of the protocol. -;;; You could write your own to handle, e.g., mailing a message to a list -;;; of addresses. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;;; This is broken -- the (SYSTEM-NAME) proc returns a local name, not -;;; a useful Internet host name. How do we do that? -;;; [Andreas:] I've inserted a way to do this. It works fine on my -;;; system. Does it work on your, too? - -;;; (sendmail to-list body [host]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Mail message to recipients in list TO-LIST. Message handed off to server -;;; running on HOST; default is the local host. Returns two values: code and -;;; text-list. However, if only problem with message is that some recipients -;;; were rejected, sendmail sends to the rest of the recipients, and the -;;; partial-success return is [700 loser-alist] where loser-alist -;;; is a list whose elements are of the form (loser-recipient code . text) -- -;;; that is, for each recipient refused by the server, you get the error -;;; data sent back for that guy. The success check is (< code 400). -;;; -;;; BODY is a string or an input port. - -(define (sendmail to-list body . maybe-host) - (call-with-current-continuation - (lambda (bailout) - (let ((local (host-info:name (host-info (system-name)))) - (socket (smtp/open (:optional maybe-host "localhost")))) - (receive (code text) (smtp-transactions socket ; Do prologue. - (smtp/helo socket local) - (smtp/mail socket (string-append (user-login-name) - "@" local))) - (if (>= code 400) (values code text) ; error - - ;; Send over recipients and collect the losers. - (let ((losers (filter-map - (lambda (to) - (receive (code text) (smtp/rcpt socket to) - (and (>= code 400) ; Error - (cond ((>= code 600) - (smtp/quit socket) - (bailout code text)) - (else `(,to ,code ,@text)))))) - to-list))) - - ;; Send the message body and wrap things up. - (receive (code text) (smtp-transactions socket - (smtp/data socket body) - (smtp/quit socket)) - (if (and (< code 400) (null? losers)) - (values code text) - (values 700 losers)))))))))) - -;;; Trivial utility -- like map, but filter out #f's. - -(define (filter-map f lis) - (let lp ((ans '()) (lis lis)) - (if (pair? lis) - (lp (cond ((f (car lis)) => (lambda (val) (cons val ans))) - (else ans)) - (cdr lis)) - (reverse ans)))) - -(define (%sendmail from local-host to dest-host message) - (let ((socket (smtp/open dest-host))) - (smtp-transactions socket - (smtp/helo socket local-host) - (smtp/mail socket from) - (smtp/rcpt socket to) - (smtp/data socket message) - (smtp/quit socket)))) - - -;;; EXPN, VRFY, MAIL-HELP -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; These three are simple queries of the server. - -(define (smtp-query socket query arg) - (receive (code text) - (smtp-transactions socket - (smtp/helo socket (system-name)) - (query socket arg)) - (if (not (or (= code 421) (= code 221))) - (smtp/quit socket)) - (values code text))) - -(define (expn name host) - (smtp-query (smtp/open host) smtp/expn name)) - -(define (vrfy name host) - (smtp-query (smtp/open host) smtp/vrfy name)) - -(define (mail-help host . details) - (smtp-query (smtp/open host) smtp/help (apply string-append (cons " " details)))) - - -;;; (smtp-transactions socket ?transaction1 ...) -;;; (smtp-transactions/no-close socket ?transaction1 ...) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; These macros make it easy to do simple sequences of SMTP commands. -;;; -;;; Evaluate a series of expressions ?transaction1, ?transaction2, ... -;;; - Each expression should perform an SMTP transaction, -;;; and return two values: -;;; + CODE (the integer reply code) -;;; + TEXT (list of strings that came with the reply). -;;; -;;; - If the transaction's reply code is 221 or 421 (meaning the socket has -;;; been closed), then the transaction sequence is aborted, and the -;;; SMTP-TRANSACTIONS form returns the CODE and TEXT values for the current -;;; transaction. -;;; -;;; - If the reply code is an error code (in the four- or five-hundred range), -;;; the transaction sequence is aborted, and the fatal transaction's CODE -;;; and TEXT values are returned. SMTP-TRANSACTIONS will additionally -;;; close the socket for you; SMTP-TRANSACTIONS/NO-CLOSE will not. -;;; -;;; - If the transaction is the last in the transaction sequence, -;;; its CODE and TEXT values are returned. -;;; -;;; - Otherwise, we throw away the current CODE and TEXT values, and -;;; proceed to the next transaction. -;;; -;;; Since SMTP-TRANSACTIONS closes the socket whenever it aborts a sequence, -;;; an SMTP-TRANSACTIONS form terminated with an (smtp/quit socket) transaction -;;; will always close the socket. -;;; -;;; If the socket should be kept open in the case of an abort, use -;;; SMTP-TRANSACTIONS/NO-CLOSE. -;;; -;;; We abort sequences if a transaction results in a 400-class error code. -;;; So, a sequence mailing a message to five people, with 5 RCPT's, would -;;; abort if the mailing address for one of these people was wrong, rather -;;; than proceeding to mail the other four. This may not be what you want; -;;; if so, you'll have to roll your own. - -(define-syntax smtp-transactions - (syntax-rules () - ((smtp-transactions socket ?T1 ?T2 ...) - (let ((s socket)) - (receive (code text) (smtp-transactions/no-close s ?T1 ?T2 ...) - (if (<= 400 code) (smtp/quit s)) - (values code text)))))) - -(define-syntax smtp-transactions/no-close - (syntax-rules () - ((smtp-transactions/no-close socket ?T1 ?T2 ...) - ;; %smtp-transactions/no-close replicates the socket argument, - ;; so we have to force it to be a variable. - (let ((s socket)) - (%smtp-transactions/no-close s ?T1 ?T2 ...))))) - -;;; SOCKET must be a variable, hence replicable. -(define-syntax %smtp-transactions/no-close - (syntax-rules () - ((%smtp-transactions/no-close socket ?T1 ?T2 ?T3 ...) - (receive (code text) ?T1 - (if (or (= code 221) - (= code 421) ; Redundant, I know. - (<= 400 code)) - (values code text) - (%smtp-transactions/no-close socket ?T2 ?T3 ...)))) - - ((%smtp-transactions/no-close socket ?T1) - ?T1))) - -;;; I can't make this nested definition work. I'm not enough of a macro stud. -;(define-syntax smtp-transactions/no-close -; (syntax-rules () -; ((smtp-transactions/no-close socket ?T1 ...) -; (letrec-syntax ((%smtp-transactions/no-close -; (syntax-rules () -; -; ((%smtp-transactions/no-close socket ?T1 ?T2 ...) -; (receive (code text) ?T1 -; (if (or (= code 221) -; (= code 421) ; Redundant, I know. -; (<= 400 code)) -; (values code text) -; (%smtp-transactions/no-close socket ?T2 ...)))) -; -; ((%smtp-transactions/no-close socket ?T1) -; ?T1)))) -; -; ;; %smtp-transactions/no-close replicates the socket argument, -; ;; so we have to force it to be a variable. -; (let ((s socket)) -; (%smtp-transactions/no-close s ?T1 ...)))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The basics of the protocol - -(define (nullary-smtp-command command) - (lambda (socket) - (let ((port (socket:outport socket))) - (write-string command port) - (write-crlf port)) - (handle-smtp-reply socket))) - - -(define (unary-smtp-command command) - (lambda (socket data) - (let ((port (socket:outport socket))) - (write-string command port) - (display #\space port) - (write-string data port) - (write-crlf port)) - (handle-smtp-reply socket))) - - -(define (smtp/open host . maybe-port) - (let ((sock (socket-connect protocol-family/internet socket-type/stream host - (:optional maybe-port "smtp")))) - (receive (code text) (handle-smtp-reply sock) - (if (< code 400) sock - (error "SMTP socket-open server-reply error" sock code text))))) - -;; HELLO -(define smtp/helo (unary-smtp-command "HELO")) - -;; MAIL FROM: -(define smtp/mail (unary-smtp-command "MAIL FROM:")) - -;; RECIPIENT TO: -(define smtp/rcpt (unary-smtp-command "RCPT TO:")) - -;; DATA -(define smtp/data - (let ((send-DATA-msg (nullary-smtp-command "DATA"))) - (lambda (socket message) ; MESSAGE is a string or an input port. - (receive (code text) (send-DATA-msg socket) - (if (>= code 400) (values code text) ; Error. - - ;; We got a positive acknowledgement for the DATA msg, - ;; now send the message body. - (let ((p (socket:outport socket))) - (cond ((string? message) - (receive (data last-char) (smtp-stuff message #f) - (write-string data p))) - - ((input-port? message) - (let lp ((last-char #f)) - (cond ((read-string/partial 1024 message) => - (lambda (chunk) - (receive (data last-char) - (smtp-stuff chunk last-char) - (write-string data p) - (lp last-char))))))) - - (else (error "Message must be string or input-port."))) - - (write-string "\r\n.\r\n" p) - (force-output p) - (handle-smtp-reply socket))))))) - -;; SEND FROM: -(define smtp/send (unary-smtp-command "SEND FROM:")) - -;; SEND OR MAIL -(define smtp/soml (unary-smtp-command "SOML FROM:")) - -;; SEND AND MAIL -(define smtp/saml (unary-smtp-command "SOML SAML:")) - -;; RESET -(define smtp/rset (nullary-smtp-command "RSET")) - -;; VERIFY -(define smtp/vrfy (unary-smtp-command "VRFY")) - -;; EXPAND -(define smtp/expn (unary-smtp-command "EXPN")) - -;; HELP

-(define smtp/help - (let ((send-help (unary-smtp-command "HELP"))) - (lambda (socket . details) - (send-help socket (apply string-append details))))) - -;; NOOP -(define smtp/noop (nullary-smtp-command "NOOP")) - -;; QUIT -(define smtp/quit - (let ((quit (nullary-smtp-command "QUIT"))) - (lambda (socket) - (receive (code text) (quit socket) ; Quit & close socket gracefully. - (case code - ((221 421)) - (else (close-socket socket))) ; But close in any event. - (values code text))))) - -;; TURN -(define smtp/turn (nullary-smtp-command "TURN")) - -;;; Read and handle the reply. Return an integer (the reply code), -;;; and a list of the text lines that came tagged by the reply code. -;;; The text lines have the reply-code prefix (first 4 chars) and the -;;; terminating cr/lf's stripped. -;;; -;;; In bdc's analog of this proc, he would read another reply if the code was -;;; in the one-hundred range (1xx). These codes aren't even used in smtp, -;;; according to the RFC. So why? - -(define (handle-smtp-reply socket) - (receive (code text) (read-smtp-reply (socket:inport socket)) - (case code - ((221 421) (close-socket socket))) ; All done. - (values code text))) - -;;; Read a reply from the SMTP server. Returns two values: -;;; - CODE Integer. The reply code. -;;; - TEXT String list. A list of the text lines comprising the reply. -;;; Each line of text is stripped of the initial reply-code -;;; numerals (e.g., the first four chars of the reply), and -;;; the trailing cr/lf. We are in fact generous about what -;;; we take to be a line -- the protocol requires cr/lf -;;; terminators, but we'll accept just lf. This appears to -;;; true to the spirit of the "be strict in what you send, -;;; and generous in what you accept" Internet protocol philosphy. - -(define (read-smtp-reply port) - (let lp ((replies '())) - (let ((ln (read-crlf-line port))) - (if (eof-object? ln) - (values 621 (cons "Premature EOF during smtp reply." - (reverse replies))) - (receive (code line more?) (parse-smtp-reply ln) - (let ((replies (cons line replies))) - (if more? (lp replies) - (values code (reverse replies))))))))) - -;;; Parse a line of SMTP reply. Return three values: -;;; CODE integer - the reply code that prefixes the string. -;;; REST string - the rest of the line. -;;; MORE? boolean - is there more reply to read (i.e., was the numeric -;;; reply code terminated by a "-" character?) - -(define (parse-smtp-reply line) - (if (and (string? line) ; This is all checking - (> (string-length line) 3) ; to see if the line - (char-numeric? (string-ref line 0)) ; is properly formatted. - (char-numeric? (string-ref line 1)) - (char-numeric? (string-ref line 2)) - (let ((c (string-ref line 3))) - (or (char=? c #\space) (char=? c #\-)))) - - (values (string->number (substring line 0 3)) ; It is. - (substring line 4 (string-length line)) - (char=? (string-ref line 3) #\-)) - - (values 600 ; It isn't. - (string-append "Improperly-formatted smtp reply: " line) - #f))) - - -;;; The message body of a piece of email is terminated by the sequence -;;; -;;; If the message body contains this magic sequence, it has to be escaped. -;;; We do this by mapping the sequence to ; -;;; the SMTP receiver undoes this mapping. - -;;; S is a string to stuff, PCHAR was the character read just before S -;;; (which matters if it is a line-feed). If S is the first chunk of the entire -;;; msg, then PCHAR can be #f. Return two values: the stuffed string, and the -;;; last char in S (or PCHAR if S is empty). The last-char value returned can -;;; be used as the PCHAR arg for the following call to SMTP-STUFF. - -(define (smtp-stuff s pchar) - (let* ((slen (string-length s)) - (hits ; Count up all the seqs in the string. - (let lp ((count 0) - (nl? (eqv? pchar #\newline)) ; Was last char a newline? - (i 0)) - (if (< i slen) - (let ((c (string-ref s i))) - (lp (if (and nl? (char=? c #\.)) (+ count 1) count) - (eq? c #\newline) - (+ i 1))) - count)))) - - (values (if (zero? hits) s - ;; Make a new string, and do the dot-stuffing copy. - (let ((ns (make-string (+ hits slen)))) - (let lp ((nl? (eqv? pchar #\newline)) - (i 0) ; S index. - (j 0)) ; NS index. - (if (< i slen) - (let ((c (string-ref s i))) - (string-set! ns j c) - (cond ((and nl? (char=? c #\.)) - (string-set! ns (+ j 1) #\.) - (lp #f (+ i 1) (+ j 2))) - (else (lp (char=? c #\newline) (+ i 1) (+ j 1))))))) - ns)) - - (if (zero? slen) pchar (string-ref s (- slen 1)))))) ; LAST-CHAR - -;;; Reply codes -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; This material taken from the RFC. -;;; -;;; 1yz Positive Preliminary reply -;;; -;;; The command has been accepted, but the requested action -;;; is being held in abeyance, pending confirmation of the -;;; information in this reply. The sender-SMTP should send -;;; another command specifying whether to continue or abort -;;; the action. -;;; -;;; [Note: SMTP does not have any commands that allow this -;;; type of reply, and so does not have the continue or -;;; abort commands.] -;;; -;;; 2yz Positive Completion reply -;;; -;;; The requested action has been successfully completed. A -;;; new request may be initiated. -;;; -;;; 3yz Positive Intermediate reply -;;; -;;; The command has been accepted, but the requested action -;;; is being held in abeyance, pending receipt of further -;;; information. The sender-SMTP should send another command -;;; specifying this information. This reply is used in -;;; command sequence groups. -;;; -;;; 4yz Transient Negative Completion reply -;;; -;;; The command was not accepted and the requested action did -;;; not occur. However, the error condition is temporary and -;;; the action may be requested again. The sender should -;;; return to the beginning of the command sequence (if any). -;;; It is difficult to assign a meaning to "transient" when -;;; two different sites (receiver- and sender- SMTPs) must -;;; agree on the interpretation. Each reply in this category -;;; might have a different time value, but the sender-SMTP is -;;; encouraged to try again. A rule of thumb to determine if -;;; a reply fits into the 4yz or the 5yz category (see below) -;;; is that replies are 4yz if they can be repeated without -;;; any change in command form or in properties of the sender -;;; or receiver. (E.g., the command is repeated identically -;;; and the receiver does not put up a new implementation.) -;;; -;;; 5yz Permanent Negative Completion reply -;;; -;;; The command was not accepted and the requested action did -;;; not occur. The sender-SMTP is discouraged from repeating -;;; the exact request (in the same sequence). Even some -;;; "permanent" error conditions can be corrected, so the -;;; human user may want to direct the sender-SMTP to -;;; reinitiate the command sequence by direct action at some -;;; point in the future (e.g., after the spelling has been -;;; changed, or the user has altered the account status). -;;; -;;;The second digit encodes responses in specific categories: -;;; -;;; x0z Syntax -- These replies refer to syntax errors, -;;; syntactically correct commands that don't fit any -;;; functional category, and unimplemented or superfluous -;;; commands. -;;; -;;; x1z Information -- These are replies to requests for -;;; information, such as status or help. -;;; -;;; x2z Connections -- These are replies referring to the -;;; transmission channel. -;;; -;;; x3z Unspecified as yet. -;;; -;;; x4z Unspecified as yet. -;;; -;;; x5z Mail system -- These replies indicate the status of -;;; the receiver mail system vis-a-vis the requested -;;; transfer or other mail system action. - -;;; Complete list (grouped by function) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 500 Syntax error, command unrecognized -;;; [This may include errors such as command line too long] -;;; 501 Syntax error in parameters or arguments -;;; 502 Command not implemented -;;; 503 Bad sequence of commands -;;; 504 Command parameter not implemented -;;; -;;; 211 System status, or system help reply -;;; 214 Help message -;;; [Information on how to use the receiver or the meaning of a -;;; particular non-standard command; this reply is useful only -;;; to the human user] -;;; -;;; 220 Service ready -;;; 221 Service closing transmission channel -;;; 421 Service not available, -;;; closing transmission channel -;;; [This may be a reply to any command if the service knows it -;;; must shut down] -;;; -;;; 250 Requested mail action okay, completed -;;; 251 User not local; will forward to -;;; 450 Requested mail action not taken: mailbox unavailable -;;; [E.g., mailbox busy] -;;; 550 Requested action not taken: mailbox unavailable -;;; [E.g., mailbox not found, no access] -;;; 451 Requested action aborted: error in processing -;;; 551 User not local; please try -;;; 452 Requested action not taken: insufficient system storage -;;; 552 Requested mail action aborted: exceeded storage allocation -;;; 553 Requested action not taken: mailbox name not allowed -;;; [E.g., mailbox syntax incorrect] -;;; 354 Start mail input; end with . -;;; 554 Transaction failed -;;; - -;;; State diagram -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; CONNECTION ESTABLISHMENT -;;; S: 220 -;;; F: 421 -;;; HELO -;;; S: 250 -;;; E: 500, 501, 504, 421 -;;; MAIL -;;; S: 250 -;;; F: 552, 451, 452 -;;; E: 500, 501, 421 -;;; RCPT -;;; S: 250, 251 -;;; F: 550, 551, 552, 553, 450, 451, 452 -;;; E: 500, 501, 503, 421 -;;; DATA -;;; I: 354 -> data -> S: 250 -;;; F: 552, 554, 451, 452 -;;; F: 451, 554 -;;; E: 500, 501, 503, 421 -;;; RSET -;;; S: 250 -;;; E: 500, 501, 504, 421 -;;; SEND -;;; S: 250 -;;; F: 552, 451, 452 -;;; E: 500, 501, 502, 421 -;;; SOML -;;; S: 250 -;;; F: 552, 451, 452 -;;; E: 500, 501, 502, 421 -;;; SAML -;;; S: 250 -;;; F: 552, 451, 452 -;;; E: 500, 501, 502, 421 -;;; VRFY -;;; S: 250, 251 -;;; F: 550, 551, 553 -;;; E: 500, 501, 502, 504, 421 -;;; EXPN -;;; S: 250 -;;; F: 550 -;;; E: 500, 501, 502, 504, 421 -;;; HELP -;;; S: 211, 214 -;;; E: 500, 501, 502, 504, 421 -;;; NOOP -;;; S: 250 -;;; E: 500, 421 -;;; QUIT -;;; S: 221 -;;; E: 500 -;;; TURN -;;; S: 250 -;;; F: 502 -;;; E: 500, 503 diff --git a/sunet-utilities.scm b/sunet-utilities.scm deleted file mode 100644 index 734a222..0000000 --- a/sunet-utilities.scm +++ /dev/null @@ -1,16 +0,0 @@ -; some useful utilities - -(define (host-name-or-ip addr) - (with-fatal-error-handler - (lambda (condition more) - (call-with-values - (lambda () (socket-address->internet-address addr)) - (lambda (ip port) - (format-internet-host-address ip)))) - (host-info:name (host-info addr)))) - -(define (on-interrupt interrupt thunk) - (let lp ((event (most-recent-sigevent))) - (let ((next (next-sigevent event interrupt))) - (thunk) - (lp next)))) diff --git a/uri.scm b/uri.scm deleted file mode 100644 index 65c673c..0000000 --- a/uri.scm +++ /dev/null @@ -1,301 +0,0 @@ -;;; -*- Scheme -*- -;;; Copyright (c) 1995 by Olin Shivers. - -;;; URI syntax -- [scheme] : path [? search ] [# fragmentid] - -;;; Imports and non-R4RS'isms -;;; let-optionals -;;; receive values (MV return) -;;; ascii->char char->ascii -;;; index rindex -;;; char-set-index char-set-rindex -;;; string-reduce -;;; char-set package -;;; bitwise logical funs and arithmetic-shift -;;; join-strings (scsh field-reader code.) - - -;;; References: -;;; - ftp://ftp.internic.net/rfc/rfc1630.txt -;;; Original RFC -;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/URI_Overview.html -;;; General Web page of URI pointers. - -;;; I wrote a URI parser that slavishly obeyed Tim Berners-Lee's -;;; spec (rfc 1630). This was a waste of time, as most URL's do not -;;; obey his spec, which is incomplete and inconsistent with the URL spec -;;; in any event. This parser is much simpler. It parses a URI into four -;;; fields: -;;; [ ] : [ ? ] [ # fragid ] -;;; The returned fields are *not* unescaped, as the rules for parsing the -;;; component in particular need unescaped text, and are dependent -;;; on . The URL parser is responsible for doing this. -;;; If the , or portions are not specified, -;;; they are #f. Otherwise, , , and are strings; -;;; is a non-empty string list. - -;;; The parsing technique is inwards from both ends. -;;; - First we search forwards for the first reserved char (= ; / # ? : space) -;;; If it's a colon, then that's the part, otw no part. -;;; Remove it. -;;; - Then we search backwards from the end for the last reserved char. -;;; If it's a sharp, then that's the part -- remove it. -;;; - Then we search backwards from the end for the last reserved char. -;;; If it's a question-mark, then that's the part -- remove it. -;;; - What's left is the path. Split at slashes. "" -> ("") -;;; -;;; This scheme is tolerant of the various ways people build broken -;;; URI's out there on the Net , p.e. \#= is a reserved character, but -;;; used unescaped in the search-part. It was given to me by Dan -;;; Connolly of the W3C and slightly modified. - -;;; Returns four values: scheme, path, search, frag-id. Each value is -;;; either #f or a string except of the path, which is a nonempty list -;;; of string (as mentioned above). - - -(define uri-reserved (string->char-set ";/#?: =")) - -(define (parse-uri s) - (let* ((slen (string-length s)) - ;; Search forwards for colon (or intervening reserved char). - (rs1 (string-index s uri-reserved)) ; 1st reserved char - (colon (and rs1 (char=? (string-ref s rs1) #\:) rs1)) - (path-start (if colon (+ colon 1) 0)) - - ;; Search backwards for # (or intervening reserved char). - (rs-last (string-index-right s uri-reserved)) - (sharp (and rs-last (char=? (string-ref s rs-last) #\#) rs-last)) - - ;; Search backwards for ? (or intervening reserved char). - ;; (NB: #\= may be after #\? and before #\#) - (rs-penult (string-index-right - s - (char-set-delete uri-reserved #\=) - (or sharp slen))) - (ques (and rs-penult (char=? (string-ref s rs-penult) #\?) rs-penult)) - - (path-end (or ques sharp slen))) - (values (and colon (substring s 0 colon)) - (split-uri-path s path-start path-end) - (and ques (substring s (+ ques 1) (or sharp slen))) - (and sharp (substring s (+ sharp 1) slen))))) - -;;; Caution: -;;; Don't use this proc until *after* you've parsed the URL -- unescaping -;;; might introduce reserved chars (like slashes and colons) that could -;;; blow your parse. - -(define (unescape-uri s . maybe-start/end) - (let-optionals maybe-start/end ((start 0) - (end (string-length s))) - (let* ((esc-seq? (lambda (i) (and (< (+ i 2) end) - (char=? (string-ref s i) #\%) - (hex-digit? (string-ref s (+ i 1))) - (hex-digit? (string-ref s (+ i 2)))))) - (hits (let lp ((i start) (hits 0)) ; count # of esc seqs. - (if (< i end) - (if (esc-seq? i) - (lp (+ i 3) (+ hits 1)) - (lp (+ i 1) hits)) - hits)))) - - (if (and (zero? hits) (zero? start) (= end (string-length s))) s - - (let* ((nlen (- (- end start) (* hits 2))) ; the new - ; length of the - ; unescaped - ; string - (ns (make-string nlen))) ; stores the result - - (let lp ((i start) (j 0)) ; sweap over the string - (if (< j nlen) - (lp (cond - ((esc-seq? i) ; unescape - ; escape-sequence - (string-set! ns j - (let ((d1 (string-ref s (+ i 1))) - (d2 (string-ref s (+ i 2)))) - (ascii->char (+ (* 16 (hexchar->int d1)) - (hexchar->int d2))))) - (+ i 3)) - (else (string-set! ns j (string-ref s i)) - (+ i 1))) - (+ j 1)))) - ns))))) - -(define hex-digit? - (let ((hex-digits (string->char-set "0123456789abcdefABCDEF"))) - (lambda (c) (char-set-contains? hex-digits c)))) - -; make use of the fact that numbers and characters are in order in the ascii table -(define (hexchar->int c) - (- (char->ascii c) - (if (char-numeric? c) - (char->ascii #\0) - (- (if (char-upper-case? c) - (char->ascii #\A) - (char->ascii #\a)) - 10)))) - -(define int->hexchar - (let ((table '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 - #\A #\B #\C #\D #\E #\F))) - (lambda (i) (vector-ref table i)))) - - -;;; Caution: -;;; All reserved chars (e.g., slash, sharp, colon) get escaped: "=;/#?: " -;;; So don't apply this proc to chunks of text with syntactically meaningful -;;; reserved chars (e.g., paths with URI slashes or colons) -- they'll be -;;; escaped, and lose their special meaning. E.g. it would be a mistake -;;; to apply ESCAPE-URI to "//lcs.mit.edu:8001/foo/bar.html" because the -;;; slashes and colons would be escaped. - -(define uri-escaped-chars - (char-set-complement (char-set-union char-set:letter+digit - (string->char-set "$-_@.&!*\"'(),+")))) - -;;; Takes a set of chars to escape. This is because we sometimes need to -;;; escape larger sets of chars for different parts of a URI. - -(define (escape-uri s . maybe-escaped-chars) - (let-optionals maybe-escaped-chars ((escaped-chars uri-escaped-chars)) - (let ((nlen (string-fold - (lambda (c i) - (+ i - (if (char-set-contains? escaped-chars c) - 3 1))) - 0 - s))) ; new length of escaped string - (if (= nlen (string-length s)) s - (let ((ns (make-string nlen))) - (string-fold - (lambda (c i) ; replace each occurance of an - ; character to escape with %ff where ff - ; is the ascii-code in hexadecimal - ; notation - (+ i (cond - ((char-set-contains? escaped-chars c) - (string-set! ns i #\%) - (let* ((d (char->ascii c)) - (dhi (bitwise-and (arithmetic-shift d -4) #xF)) - (dlo (bitwise-and d #xF))) - (string-set! ns (+ i 1) - (int->hexchar dhi)) - (string-set! ns (+ i 2) - (int->hexchar dlo))) - 3) - (else (string-set! ns i c) - 1)))) - 0 - s) - ns))))) - - -;;; Four args: context URI's : values, and -;;; main URI's : values. -;;; If the path cannot be resolved, return #f #f (this occurs if -;;; begins with n sequential slashes, and doesn't -;;; have that many sequential slashes anywhere). All paths are -;;; represented as non-empty lists. - -(define (resolve-uri cscheme cp scheme p) - (if scheme (values scheme p) ; If URI has own , it is absolute. - - (if (and (pair? p) (string=? (car p) "")) ; Path P begins with a slash. - - (receive (numsl p) ; Count and strip off initial - (do ((i 1 (+ i 1)) ; slashes (i.e., initial ""'s) - (q (cdr p) (cdr q))) - ((or (null? q) (not (string=? (car q) ""))) - (values i q))) - - ;; Skip through CP until we find that many sequential /'s. - (let lp ((cp-tail cp) - (rhead '()) ; CP prefix, reversed. - (j 0)) ; J counts sequential / - - (cond - ((and (pair? cp-tail) (string=? (car cp-tail) "")) ; More ""'s - (lp (cdr cp-tail) - (cons (car cp-tail) rhead) - (+ j 0))) - - ((= j numsl) ; Win - (values cscheme (simplify-uri-path (rev-append rhead p)))) - - ((pair? cp-tail) ; Keep looking. - (lp (cdr cp-tail) - (cons (car cp-tail) rhead) - 1)) - - (else (values #f #f))))) ; Lose. - - - ;; P doesn't begin with a slash. - (values cscheme (simplify-uri-path - (rev-append (cdr (reverse cp)) ; Drop non-dir part - p)))))) ; and append P. - - -(define (rev-append a b) ; (append (reverse a) b) - (let rev-app ((a a) (b b)) ; Should be defined in a list-proc - (if (pair? a) ; package, not here. - (rev-app (cdr a) (cons (car a) b)) - b))) - -;;; Cribbed from scsh's fname.scm - -(define (split-uri-path uri start end) ; Split at /'s (infix grammar). - (let split ((i start)) ; "" -> ("") - (cond - ((>= i end) '("")) - ((string-index uri #\/ i) => - (lambda (slash) - (cons (substring uri i slash) - (split (+ slash 1))))) - (else (list (substring uri i end)))))) - - -;;; The elements of PLIST must be escaped in case they contain slashes. -;;; This procedure doesn't escape them for you; you must do that yourself: -;;; (uri-path-list->path (map escape-uri pathlist)) - -(define (uri-path-list->path plist) - (string-join plist "/")) ; Insert slashes between elts of PLIST. - - -;;; Remove . and /.. elements from path. The result is a -;;; (maybe empty) list representing a path that does not contain "." -;;; and ".." elements neither at the beginning nor somewhere else. I -;;; tried to follow RFC2396 here. The procedure returns #f if the path -;;; tries to back up past root (like "//.." or "/foo/../.."). "//" may -;;; occur somewhere in the path but not being backed up. Usually, -;;; relative paths are intended to be used with a base -;;; url. Accordingly to RFC2396 (as I hope) relative paths are -;;; considered not to start with "/". They are appended to a base -;;; URL-path and then simplified. So before you start to simplify a -;;; URL try to find out if it is a relative path (i.e. it does not -;;; start with a "/"). - -(define (simplify-uri-path p) - (if (null? p) #f ; P must be non-null - (let lp ((path-list (cdr p)) - (stack (list (car p)))) - (if (null? path-list) ; we're done - (reverse stack) - (cond - ((string=? (car path-list) "..") ; back up - ; neither the empty path nor root - (if (not (or (null? stack) (string=? (car stack) ""))) - (lp (cdr path-list) (cdr stack)) - #f)) - ((string=? (car path-list) ".") ; leave this - (lp (cdr path-list) stack)) - ((string=? (car path-list) "") ; back to root - (lp (cdr path-list) '(""))) - (else ; usual segment - (lp (cdr path-list) (cons (car path-list) stack)))))))) - - \ No newline at end of file diff --git a/url.scm b/url.scm deleted file mode 100644 index 80a27d7..0000000 --- a/url.scm +++ /dev/null @@ -1,152 +0,0 @@ -;;; URL parsing and unparsing -*- Scheme -*- -;;; Copyright (c) 1995 by Olin Shivers. - -;;; I'm only implementing http URL's right now. - -;;; References: -;;; - ftp://ftp.internic.net/rfc/rfc1738.txt -;;; Original RFC -;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/Overview.html -;;; General Web page of URI pointers. - - -;;; Unresolved issues: -;;; - The userhost parser shouldn't substitute default values -- -;;; that should happen in a separate step. - -;;; Imports and non-R4RS'isms -;;; define-record Record structures -;;; receive values MV return -;;; URI support -;;; string-index - -;;; The steps in hacking a URL are: -;;; - Take the UID, parse it, and resolve it with the context UID, if any. -;;; - Consult the UID's . Pick the appropriate URL parser and parse. - - -;;; Userhost strings: //:@:/ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; A USERHOST record describes path-prefixes of the form -;;; //:@:/ -;;; These are frequently used as the initial prefix of URL's describing -;;; Internet resources. - -(define-record userhost ; Each slot is a decoded string or #f. - user - password - host - port) - -;;; Parse a URI path (a list representing a path, not a string!) into -;;; a userhost record. Default values are taken from the userhost -;;; record DEFAULT except for the host. Returns a userhost record if -;;; it wins. CADDR drops the userhost portion of the path. In fact, -;;; fatal-syntax-error is called, if the path doesn't start with '//'. - -(define (parse-userhost path default) - (if (and (pair? path) ; The thing better begin - (string=? (car path) "") ; with // (i.e., have two - (pair? (cdr path)) ; initial "" elements). - (string=? (cadr path) "")) - - (let* ((uhs (caddr path)) ; Userhost string. - (uhs-len (string-length uhs)) - ; Usr:passwd at-sign, - (at (string-index uhs #\@)) ; if any. - - (colon1 (and at (string-index uhs #\:))) ; Usr:passwd colon, - (colon1 (and colon1 (< colon1 at) colon1)) ; if any. - - (colon2 (string-index uhs #\: (or at 0)))) ; Host:port colon, - ; if any. - (make-userhost (if at - (unescape-uri uhs 0 (or colon1 at)) - (userhost:user default)) - (if colon1 - (unescape-uri uhs (+ colon1 1) at) - (userhost:password default)) - (unescape-uri uhs (if at (+ at 1) 0) - (or colon2 uhs-len)) - (if colon2 - (unescape-uri uhs (+ colon2 1) uhs-len) - (userhost:port default)))) - - (fatal-syntax-error "URL must begin with //..." path))) - -;;; Unparser - -(define userhost-escaped-chars - (char-set-union uri-escaped-chars ; @ and : are also special - (string->char-set "@:"))) ; in UH strings. - -(define (userhost->string uh) - (let* ((us (userhost:user uh)) - (pw (userhost:password uh)) - (ho (userhost:host uh)) - (po (userhost:port uh)) - - ;; Encode before assembly in case pieces contain colons or at-signs. - (e (lambda (s) (escape-uri s userhost-escaped-chars))) - - (user/passwd (if us `(,(e us) . ,(if pw `(":" ,(e pw) "@") '("@"))) - '())) - (host/port (if ho `(,(e ho) . ,(if po `(":" ,(e po)) '())) - '()))) - - (apply string-append (append user/passwd host/port)))) - - -;;; HTTP URL parsing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; The PATH slot of this record is the URL's path split at slashes, -;;; e.g., "foo/bar//baz/" => ("foo" "bar" "" "baz" "") -;;; These elements are in raw, unescaped format. To convert back to -;;; a string, use (uri-path-list->path (map escape-uri pathlist)). - -(define-record http-url - userhost ; Initial //anonymous@clark.lcs.mit.edu:80/ - path ; Rest of path, split at slashes & decoded. - search - frag-id) - -;;; The URI parser (parse-uri in uri.scm) maps a string to four parts: -;;; : ? # , , and -;;; are strings; is a non-empty string list -- the -;;; URI's path split at slashes. Optional parts of the URI, when -;;; missing, are specified as #f. If is "http", then the -;;; other three parts can be passed to PARSE-HTTP-URL, which parses -;;; them into a HTTP-URL record. All strings come back from the URI -;;; parser encoded. SEARCH and FRAG-ID are left that way; this parser -;;; decodes the path elements. -;;; -;;; Returns a HTTP-URL record, if possible. Otherwise -;;; FATAL-SYNTAX-ERROR is called. - -(define (parse-http-url path search frag-id) - (let ((uh (parse-userhost path default-http-userhost))) - (if (or (userhost:user uh) (userhost:password uh)) - (fatal-syntax-error - "HTTP URL's may not specify a user or password field" path)) - - (make-http-url uh (map unescape-uri (cdddr path)) search frag-id))) - - -;;; Default http port is 80. -(define default-http-userhost (make-userhost #f #f #f "80")) - - -;;; Unparse. - -(define (http-url->string url) - (string-append "http://" - (userhost->string (http-url:userhost url)) - "/" - (uri-path-list->path (map escape-uri (http-url:path url))) - (cond ((http-url:search url) => - (lambda (s) (string-append "?" s))) - (else "")) - (cond ((http-url:frag-id url) => - (lambda (fi) (string-append "#" fi))) - (else ""))))