diff --git a/collects/mzlib/cm.ss b/collects/mzlib/cm.ss index 164cc36..268ed85 100644 --- a/collects/mzlib/cm.ss +++ b/collects/mzlib/cm.ss @@ -131,7 +131,20 @@ [code (parameterize ([param (lambda (ext-file) (set! external-deps (cons (path->bytes ext-file) - external-deps)))]) + external-deps)))] + [current-reader-guard + (let ([rg (current-reader-guard)]) + (lambda (d) + (let ([d (rg d)]) + (when (module-path? d) + (let ([p (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join d #f)))]) + (when (path? p) + (set! external-deps + (cons (path->bytes p) + external-deps))))) + d)))]) (get-module-code path mode))] [code-dir (get-code-dir mode path)]) (if (not (directory-exists? code-dir)) diff --git a/collects/net/base64-unit.ss b/collects/net/base64-unit.ss index 79f2117..55cecc6 100644 --- a/collects/net/base64-unit.ss +++ b/collects/net/base64-unit.ss @@ -1,49 +1,48 @@ - #lang scheme/unit - (require "base64-sig.ss") +(require "base64-sig.ss") - (import) - (export base64^) +(import) +(export base64^) - (define base64-digit (make-vector 256)) - (let loop ([n 0]) - (unless (= n 256) - (cond [(<= (char->integer #\A) n (char->integer #\Z)) - (vector-set! base64-digit n (- n (char->integer #\A)))] - [(<= (char->integer #\a) n (char->integer #\z)) - (vector-set! base64-digit n (+ 26 (- n (char->integer #\a))))] - [(<= (char->integer #\0) n (char->integer #\9)) - (vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))] - [(= (char->integer #\+) n) - (vector-set! base64-digit n 62)] - [(= (char->integer #\/) n) - (vector-set! base64-digit n 63)] - [else - (vector-set! base64-digit n #f)]) - (loop (add1 n)))) +(define base64-digit (make-vector 256)) +(let loop ([n 0]) + (unless (= n 256) + (cond [(<= (char->integer #\A) n (char->integer #\Z)) + (vector-set! base64-digit n (- n (char->integer #\A)))] + [(<= (char->integer #\a) n (char->integer #\z)) + (vector-set! base64-digit n (+ 26 (- n (char->integer #\a))))] + [(<= (char->integer #\0) n (char->integer #\9)) + (vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))] + [(= (char->integer #\+) n) + (vector-set! base64-digit n 62)] + [(= (char->integer #\/) n) + (vector-set! base64-digit n 63)] + [else + (vector-set! base64-digit n #f)]) + (loop (add1 n)))) - (define digit-base64 (make-vector 64)) - (define (each-char s e pos) - (let loop ([i (char->integer s)][pos pos]) - (unless (> i (char->integer e)) - (vector-set! digit-base64 pos i) - (loop (add1 i) (add1 pos))))) - (each-char #\A #\Z 0) - (each-char #\a #\z 26) - (each-char #\0 #\9 52) - (each-char #\+ #\+ 62) - (each-char #\/ #\/ 63) +(define digit-base64 (make-vector 64)) +(define (each-char s e pos) + (let loop ([i (char->integer s)][pos pos]) + (unless (> i (char->integer e)) + (vector-set! digit-base64 pos i) + (loop (add1 i) (add1 pos))))) +(each-char #\A #\Z 0) +(each-char #\a #\z 26) +(each-char #\0 #\9 52) +(each-char #\+ #\+ 62) +(each-char #\/ #\/ 63) - (define (base64-filename-safe) - (vector-set! base64-digit (char->integer #\-) 62) - (vector-set! base64-digit (char->integer #\_) 63) - (each-char #\- #\- 62) - (each-char #\_ #\_ 63)) +(define (base64-filename-safe) + (vector-set! base64-digit (char->integer #\-) 62) + (vector-set! base64-digit (char->integer #\_) 63) + (each-char #\- #\- 62) + (each-char #\_ #\_ 63)) - (define (base64-decode-stream in out) - (let loop ([waiting 0][waiting-bits 0]) - (if (>= waiting-bits 8) +(define (base64-decode-stream in out) + (let loop ([waiting 0][waiting-bits 0]) + (if (>= waiting-bits 8) (begin (write-byte (arithmetic-shift waiting (- 8 waiting-bits)) out) (let ([waiting-bits (- waiting-bits 8)]) @@ -57,79 +56,79 @@ [(eq? c (char->integer #\=)) (void)] ; done [else (loop waiting waiting-bits)]))))) - (define base64-encode-stream - (case-lambda - [(in out) (base64-encode-stream in out #"\n")] - [(in out linesep) - ;; Process input 3 characters at a time, because 18 bits - ;; is divisible by both 6 and 8, and 72 (the line length) - ;; is divisible by 3. - (let ([three (make-bytes 3)] - [outc (lambda (n) - (write-byte (vector-ref digit-base64 n) out))] - [done (lambda (fill) - (let loop ([fill fill]) - (unless (zero? fill) - (write-byte (char->integer #\=) out) - (loop (sub1 fill)))) - (display linesep out))]) - (let loop ([pos 0]) - (if (= pos 72) - ;; Insert newline - (begin - (display linesep out) - (loop 0)) - ;; Next group of 3 - (let ([n (read-bytes-avail! three in)]) - (cond - [(eof-object? n) - (unless (= pos 0) (done 0))] - [(= n 3) - ;; Easy case: - (let ([a (bytes-ref three 0)] - [b (bytes-ref three 1)] - [c (bytes-ref three 2)]) - (outc (arithmetic-shift a -2)) - (outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) - (arithmetic-shift b -4))) - (outc (+ (bitwise-and #x3f (arithmetic-shift b 2)) - (arithmetic-shift c -6))) - (outc (bitwise-and #x3f c)) - (loop (+ pos 4)))] - [else - ;; Hard case: n is 1 or 2 - (let ([a (bytes-ref three 0)]) - (outc (arithmetic-shift a -2)) - (let* ([next (if (= n 2) +(define base64-encode-stream + (case-lambda + [(in out) (base64-encode-stream in out #"\n")] + [(in out linesep) + ;; Process input 3 characters at a time, because 18 bits + ;; is divisible by both 6 and 8, and 72 (the line length) + ;; is divisible by 3. + (let ([three (make-bytes 3)] + [outc (lambda (n) + (write-byte (vector-ref digit-base64 n) out))] + [done (lambda (fill) + (let loop ([fill fill]) + (unless (zero? fill) + (write-byte (char->integer #\=) out) + (loop (sub1 fill)))) + (display linesep out))]) + (let loop ([pos 0]) + (if (= pos 72) + ;; Insert newline + (begin + (display linesep out) + (loop 0)) + ;; Next group of 3 + (let ([n (read-bytes-avail! three in)]) + (cond + [(eof-object? n) + (unless (= pos 0) (done 0))] + [(= n 3) + ;; Easy case: + (let ([a (bytes-ref three 0)] + [b (bytes-ref three 1)] + [c (bytes-ref three 2)]) + (outc (arithmetic-shift a -2)) + (outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) + (arithmetic-shift b -4))) + (outc (+ (bitwise-and #x3f (arithmetic-shift b 2)) + (arithmetic-shift c -6))) + (outc (bitwise-and #x3f c)) + (loop (+ pos 4)))] + [else + ;; Hard case: n is 1 or 2 + (let ([a (bytes-ref three 0)]) + (outc (arithmetic-shift a -2)) + (let* ([next (if (= n 2) (bytes-ref three 1) (read-byte in))] - [b (if (eof-object? next) + [b (if (eof-object? next) 0 next)]) - (outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) - (arithmetic-shift b -4))) - (if (eof-object? next) + (outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) + (arithmetic-shift b -4))) + (if (eof-object? next) (done 2) ;; More to go (let* ([next (read-byte in)] [c (if (eof-object? next) - 0 - next)]) + 0 + next)]) (outc (+ (bitwise-and #x3f (arithmetic-shift b 2)) (arithmetic-shift c -6))) (if (eof-object? next) - (done 1) - ;; Finish c, loop - (begin - (outc (bitwise-and #x3f c)) - (loop (+ pos 4))))))))])))))])) + (done 1) + ;; Finish c, loop + (begin + (outc (bitwise-and #x3f c)) + (loop (+ pos 4))))))))])))))])) - (define (base64-decode src) - (let ([s (open-output-bytes)]) - (base64-decode-stream (open-input-bytes src) s) - (get-output-bytes s))) +(define (base64-decode src) + (let ([s (open-output-bytes)]) + (base64-decode-stream (open-input-bytes src) s) + (get-output-bytes s))) - (define (base64-encode src) - (let ([s (open-output-bytes)]) - (base64-encode-stream (open-input-bytes src) s (bytes 13 10)) - (get-output-bytes s))) +(define (base64-encode src) + (let ([s (open-output-bytes)]) + (base64-encode-stream (open-input-bytes src) s (bytes 13 10)) + (get-output-bytes s))) diff --git a/collects/net/cookie-unit.ss b/collects/net/cookie-unit.ss index e1fdf79..1011f58 100644 --- a/collects/net/cookie-unit.ss +++ b/collects/net/cookie-unit.ss @@ -59,7 +59,7 @@ (import) (export cookie^) - (define-struct cookie (name value comment domain max-age path secure version)) + (define-struct cookie (name value comment domain max-age path secure version) #:mutable) (define-struct (cookie-error exn:fail) ()) ;; error* : string args ... -> raises a cookie-error exception diff --git a/collects/net/dns-unit.ss b/collects/net/dns-unit.ss index 7008c84..4476f1d 100644 --- a/collects/net/dns-unit.ss +++ b/collects/net/dns-unit.ss @@ -1,6 +1,7 @@ #lang scheme/unit - (require (lib "list.ss") (lib "process.ss") "dns-sig.ss") + (require (lib "list.ss") (lib "process.ss") "dns-sig.ss" + scheme/udp) (import) (export dns^) diff --git a/collects/net/ftp-unit.ss b/collects/net/ftp-unit.ss index 9815f67..2895e98 100644 --- a/collects/net/ftp-unit.ss +++ b/collects/net/ftp-unit.ss @@ -1,82 +1,82 @@ #lang scheme/unit - ;; Version 0.2 - ;; Version 0.1a - ;; Micah Flatt - ;; 06-06-2002 - (require (lib "date.ss") (lib "file.ss") (lib "port.ss") "ftp-sig.ss") - (import) - (export ftp^) +;; Version 0.2 +;; Version 0.1a +;; Micah Flatt +;; 06-06-2002 +(require scheme/date scheme/file scheme/port scheme/tcp "ftp-sig.ss") +(import) +(export ftp^) - ;; opqaue record to represent an FTP connection: - (define-struct tcp-connection (in out)) +;; opqaue record to represent an FTP connection: +(define-struct tcp-connection (in out)) - (define tzoffset (date-time-zone-offset (seconds->date (current-seconds)))) +(define tzoffset (date-time-zone-offset (seconds->date (current-seconds)))) - (define re:multi-response-start #rx#"^[0-9][0-9][0-9]-") - (define re:response-end #rx#"^[0-9][0-9][0-9] ") +(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-") +(define re:response-end #rx#"^[0-9][0-9][0-9] ") - (define (check-expected-result line expected) - (when expected - (unless (ormap (lambda (expected) - (bytes=? expected (subbytes line 0 3))) - (if (bytes? expected) +(define (check-expected-result line expected) + (when expected + (unless (ormap (lambda (expected) + (bytes=? expected (subbytes line 0 3))) + (if (bytes? expected) (list expected) expected)) - (error 'ftp "exected result code ~a, got ~a" expected line)))) + (error 'ftp "exected result code ~a, got ~a" expected line)))) - ;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any - ;; - ;; Checks a standard-format response, checking for the given - ;; expected 3-digit result code if expected is not #f. - ;; - ;; While checking, the function sends reponse lines to - ;; diagnostic-accum. This function -accum functions can return a - ;; value that accumulates over multiple calls to the function, and - ;; accum-start is used as the initial value. Use `void' and - ;; `(void)' to ignore the response info. - ;; - ;; If an unexpected result is found, an exception is raised, and the - ;; stream is left in an undefined state. - (define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start) - (flush-output tcpout) - (let ([line (read-bytes-line tcpin 'any)]) - (cond - [(eof-object? line) - (error 'ftp "unexpected EOF")] - [(regexp-match re:multi-response-start line) - (check-expected-result line expected) - (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))]) - (let loop ([accum (diagnostic-accum line accum-start)]) - (let ([line (read-bytes-line tcpin 'any)]) - (cond [(eof-object? line) - (error 'ftp "unexpected EOF")] - [(regexp-match re:done line) - (diagnostic-accum line accum)] - [else - (loop (diagnostic-accum line accum))]))))] - [(regexp-match re:response-end line) - (check-expected-result line expected) - (diagnostic-accum line accum-start)] - [else - (error 'ftp "unexpected result: ~e" line)]))) +;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any +;; +;; Checks a standard-format response, checking for the given +;; expected 3-digit result code if expected is not #f. +;; +;; While checking, the function sends reponse lines to +;; diagnostic-accum. This function -accum functions can return a +;; value that accumulates over multiple calls to the function, and +;; accum-start is used as the initial value. Use `void' and +;; `(void)' to ignore the response info. +;; +;; If an unexpected result is found, an exception is raised, and the +;; stream is left in an undefined state. +(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start) + (flush-output tcpout) + (let ([line (read-bytes-line tcpin 'any)]) + (cond + [(eof-object? line) + (error 'ftp "unexpected EOF")] + [(regexp-match re:multi-response-start line) + (check-expected-result line expected) + (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))]) + (let loop ([accum (diagnostic-accum line accum-start)]) + (let ([line (read-bytes-line tcpin 'any)]) + (cond [(eof-object? line) + (error 'ftp "unexpected EOF")] + [(regexp-match re:done line) + (diagnostic-accum line accum)] + [else + (loop (diagnostic-accum line accum))]))))] + [(regexp-match re:response-end line) + (check-expected-result line expected) + (diagnostic-accum line accum-start)] + [else + (error 'ftp "unexpected result: ~e" line)]))) - (define (get-month month-bytes) - (cond [(assoc month-bytes - '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5) - (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10) - (#"Nov" 11) (#"Dec" 12))) - => cadr] - [else (error 'get-month "bad month: ~s" month-bytes)])) +(define (get-month month-bytes) + (cond [(assoc month-bytes + '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5) + (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10) + (#"Nov" 11) (#"Dec" 12))) + => cadr] + [else (error 'get-month "bad month: ~s" month-bytes)])) - (define (bytes->number bytes) - (string->number (bytes->string/latin-1 bytes))) +(define (bytes->number bytes) + (string->number (bytes->string/latin-1 bytes))) - (define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") +(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") - (define (ftp-make-file-seconds ftp-date-str) - (let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))]) - (if (not (list-ref date-list 4)) +(define (ftp-make-file-seconds ftp-date-str) + (let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))]) + (if (not (list-ref date-list 4)) (find-seconds 0 0 2 @@ -91,128 +91,128 @@ 2002) tzoffset)))) - (define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)") +(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)") - (define (establish-data-connection tcp-ports) - (fprintf (tcp-connection-out tcp-ports) "PASV\n") - (let ([response (ftp-check-response - (tcp-connection-in tcp-ports) - (tcp-connection-out tcp-ports) - #"227" - (lambda (s ignore) s) ; should be the only response - (void))]) - (let* ([reg-list (regexp-match re:passive response)] - [pn1 (and reg-list - (bytes->number (list-ref reg-list 5)))] - [pn2 (bytes->number (list-ref reg-list 6))]) - (unless (and reg-list pn1 pn2) - (error 'ftp "can't understand PASV response: ~e" response)) - (let-values ([(tcp-data tcp-data-out) - (tcp-connect (format "~a.~a.~a.~a" - (list-ref reg-list 1) - (list-ref reg-list 2) - (list-ref reg-list 3) - (list-ref reg-list 4)) - (+ (* 256 pn1) pn2))]) - (fprintf (tcp-connection-out tcp-ports) "TYPE I\n") - (ftp-check-response (tcp-connection-in tcp-ports) - (tcp-connection-out tcp-ports) - #"200" void (void)) - (close-output-port tcp-data-out) - tcp-data)))) - - ;; Used where version 0.1a printed responses: - (define (print-msg s ignore) - ;; (printf "~a\n" s) - (void)) - - (define (ftp-establish-connection* in out username password) - (ftp-check-response in out #"220" print-msg (void)) - (display (bytes-append #"USER " (string->bytes/locale username) #"\n") out) - (let ([no-password? (ftp-check-response - in out (list #"331" #"230") - (lambda (line 230?) - (or 230? (regexp-match #rx#"^230" line))) - #f)]) - (unless no-password? - (display (bytes-append #"PASS " (string->bytes/locale password) #"\n") - out) - (ftp-check-response in out #"230" void (void)))) - (make-tcp-connection in out)) - - (define (ftp-establish-connection server-address server-port username password) - (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)]) - (ftp-establish-connection* tcpin tcpout username password))) - - (define (ftp-close-connection tcp-ports) - (fprintf (tcp-connection-out tcp-ports) "QUIT\n") - (ftp-check-response (tcp-connection-in tcp-ports) - (tcp-connection-out tcp-ports) - #"221" void (void)) - (close-input-port (tcp-connection-in tcp-ports)) - (close-output-port (tcp-connection-out tcp-ports))) - - (define (filter-tcp-data tcp-data-port regular-exp) - (let loop () - (let ([theline (read-bytes-line tcp-data-port 'any)]) - (cond [(or (eof-object? theline) (< (bytes-length theline) 3)) - null] - [(regexp-match regular-exp theline) - => (lambda (m) (cons (cdr m) (loop)))] - [else - ;; ignore unrecognized lines? - (loop)])))) - - (define (ftp-cd ftp-ports new-dir) - (display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n") - (tcp-connection-out ftp-ports)) - (ftp-check-response (tcp-connection-in ftp-ports) - (tcp-connection-out ftp-ports) - #"250" void (void))) - - (define re:dir-line - #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$") - - (define (ftp-directory-list tcp-ports) - (let ([tcp-data (establish-data-connection tcp-ports)]) - (fprintf (tcp-connection-out tcp-ports) "LIST\n") - (ftp-check-response (tcp-connection-in tcp-ports) - (tcp-connection-out tcp-ports) - #"150" void (void)) - (let ([dir-list (filter-tcp-data tcp-data re:dir-line)]) - (close-input-port tcp-data) +(define (establish-data-connection tcp-ports) + (fprintf (tcp-connection-out tcp-ports) "PASV\n") + (let ([response (ftp-check-response + (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"227" + (lambda (s ignore) s) ; should be the only response + (void))]) + (let* ([reg-list (regexp-match re:passive response)] + [pn1 (and reg-list + (bytes->number (list-ref reg-list 5)))] + [pn2 (bytes->number (list-ref reg-list 6))]) + (unless (and reg-list pn1 pn2) + (error 'ftp "can't understand PASV response: ~e" response)) + (let-values ([(tcp-data tcp-data-out) + (tcp-connect (format "~a.~a.~a.~a" + (list-ref reg-list 1) + (list-ref reg-list 2) + (list-ref reg-list 3) + (list-ref reg-list 4)) + (+ (* 256 pn1) pn2))]) + (fprintf (tcp-connection-out tcp-ports) "TYPE I\n") (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) - #"226" print-msg (void)) - (map (lambda (l) (map bytes->string/locale l)) dir-list)))) + #"200" void (void)) + (close-output-port tcp-data-out) + tcp-data)))) - (define (ftp-download-file tcp-ports folder filename) - ;; Save the file under the name tmp.file, rename it once download is - ;; complete this assures we don't over write any existing file without - ;; having a good file down - (let* ([tmpfile (make-temporary-file - (string-append - (regexp-replace - #rx"~" - (path->string (build-path folder "ftptmp")) - "~~") - "~a"))] - [new-file (open-output-file tmpfile 'replace)] - [tcpstring (bytes-append #"RETR " - (string->bytes/locale filename) - #"\n")] - [tcp-data (establish-data-connection tcp-ports)]) - (display tcpstring (tcp-connection-out tcp-ports)) - (ftp-check-response (tcp-connection-in tcp-ports) - (tcp-connection-out tcp-ports) - #"150" print-msg (void)) - (copy-port tcp-data new-file) - (close-output-port new-file) +;; Used where version 0.1a printed responses: +(define (print-msg s ignore) + ;; (printf "~a\n" s) + (void)) + +(define (ftp-establish-connection* in out username password) + (ftp-check-response in out #"220" print-msg (void)) + (display (bytes-append #"USER " (string->bytes/locale username) #"\n") out) + (let ([no-password? (ftp-check-response + in out (list #"331" #"230") + (lambda (line 230?) + (or 230? (regexp-match #rx#"^230" line))) + #f)]) + (unless no-password? + (display (bytes-append #"PASS " (string->bytes/locale password) #"\n") + out) + (ftp-check-response in out #"230" void (void)))) + (make-tcp-connection in out)) + +(define (ftp-establish-connection server-address server-port username password) + (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)]) + (ftp-establish-connection* tcpin tcpout username password))) + +(define (ftp-close-connection tcp-ports) + (fprintf (tcp-connection-out tcp-ports) "QUIT\n") + (ftp-check-response (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"221" void (void)) + (close-input-port (tcp-connection-in tcp-ports)) + (close-output-port (tcp-connection-out tcp-ports))) + +(define (filter-tcp-data tcp-data-port regular-exp) + (let loop () + (let ([theline (read-bytes-line tcp-data-port 'any)]) + (cond [(or (eof-object? theline) (< (bytes-length theline) 3)) + null] + [(regexp-match regular-exp theline) + => (lambda (m) (cons (cdr m) (loop)))] + [else + ;; ignore unrecognized lines? + (loop)])))) + +(define (ftp-cd ftp-ports new-dir) + (display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n") + (tcp-connection-out ftp-ports)) + (ftp-check-response (tcp-connection-in ftp-ports) + (tcp-connection-out ftp-ports) + #"250" void (void))) + +(define re:dir-line + #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$") + +(define (ftp-directory-list tcp-ports) + (let ([tcp-data (establish-data-connection tcp-ports)]) + (fprintf (tcp-connection-out tcp-ports) "LIST\n") + (ftp-check-response (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"150" void (void)) + (let ([dir-list (filter-tcp-data tcp-data re:dir-line)]) (close-input-port tcp-data) (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) #"226" print-msg (void)) - (rename-file-or-directory tmpfile (build-path folder filename) #t))) + (map (lambda (l) (map bytes->string/locale l)) dir-list)))) - ;; (printf "FTP Client Installed...\n") +(define (ftp-download-file tcp-ports folder filename) + ;; Save the file under the name tmp.file, rename it once download is + ;; complete this assures we don't over write any existing file without + ;; having a good file down + (let* ([tmpfile (make-temporary-file + (string-append + (regexp-replace + #rx"~" + (path->string (build-path folder "ftptmp")) + "~~") + "~a"))] + [new-file (open-output-file tmpfile 'replace)] + [tcpstring (bytes-append #"RETR " + (string->bytes/locale filename) + #"\n")] + [tcp-data (establish-data-connection tcp-ports)]) + (display tcpstring (tcp-connection-out tcp-ports)) + (ftp-check-response (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"150" print-msg (void)) + (copy-port tcp-data new-file) + (close-output-port new-file) + (close-input-port tcp-data) + (ftp-check-response (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"226" print-msg (void)) + (rename-file-or-directory tmpfile (build-path folder filename) #t))) + +;; (printf "FTP Client Installed...\n") diff --git a/collects/net/imap-unit.ss b/collects/net/imap-unit.ss index 79d4075..14cf2f4 100644 --- a/collects/net/imap-unit.ss +++ b/collects/net/imap-unit.ss @@ -1,6 +1,8 @@ #lang scheme/unit - (require (lib "list.ss") "imap-sig.ss" "private/rbtree.ss") + (require scheme/tcp + "imap-sig.ss" + "private/rbtree.ss") (import) (export imap^) @@ -252,7 +254,8 @@ (info-handler i))) (define-struct imap (r w exists recent unseen uidnext uidvalidity - expunges fetches new?)) + expunges fetches new?) + #:mutable) (define (imap-connection? v) (imap? v)) (define imap-port-number diff --git a/collects/net/mime-sig.ss b/collects/net/mime-sig.ss index da6db0f..ca911b0 100644 --- a/collects/net/mime-sig.ss +++ b/collects/net/mime-sig.ss @@ -1,14 +1,14 @@ #lang scheme/signature ;; -- exceptions raised -- -(struct mime-error () -setters -constructor) -(struct unexpected-termination (msg) -setters -constructor) -(struct missing-multipart-boundary-parameter () -setters -constructor) -(struct malformed-multipart-entity (msg) -setters -constructor) -(struct empty-mechanism () -setters -constructor) -(struct empty-type () -setters -constructor) -(struct empty-subtype () -setters -constructor) -(struct empty-disposition-type () -setters -constructor) +(struct mime-error () #:omit-constructor) +(struct unexpected-termination (msg) #:omit-constructor) +(struct missing-multipart-boundary-parameter () #:omit-constructor) +(struct malformed-multipart-entity (msg) #:omit-constructor) +(struct empty-mechanism () #:omit-constructor) +(struct empty-type () #:omit-constructor) +(struct empty-subtype () #:omit-constructor) +(struct empty-disposition-type () #:omit-constructor) ;; -- basic mime structures -- (struct message (version entity fields)) diff --git a/collects/net/mime-unit.ss b/collects/net/mime-unit.ss index 2361b37..557b126 100644 --- a/collects/net/mime-unit.ss +++ b/collects/net/mime-unit.ss @@ -121,12 +121,15 @@ ("quicktime" . quicktime))) ;; Basic structures - (define-struct message (version entity fields)) + (define-struct message (version entity fields) + #:mutable) (define-struct entity (type subtype charset encoding disposition params id description other - fields parts body)) + fields parts body) + #:mutable) (define-struct disposition - (type filename creation modification read size params)) + (type filename creation modification read size params) + #:mutable) ;; Exceptions (define-struct mime-error ()) @@ -227,7 +230,7 @@ [(message multipart) (let ([boundary (entity-boundary entity)]) (when (not boundary) - (if (eq? 'multipart (entity-type entity)) + (when (eq? 'multipart (entity-type entity)) (raise (make-missing-multipart-boundary-parameter)))) (set-entity-parts! entity (map (lambda (part) diff --git a/collects/net/nntp-unit.ss b/collects/net/nntp-unit.ss index 4bf91e6..eee9b36 100644 --- a/collects/net/nntp-unit.ss +++ b/collects/net/nntp-unit.ss @@ -1,150 +1,150 @@ #lang scheme/unit - (require (lib "etc.ss") "nntp-sig.ss") +(require scheme/tcp "nntp-sig.ss") - (import) - (export nntp^) +(import) +(export nntp^) - ;; sender : oport - ;; receiver : iport - ;; server : string - ;; port : number +;; sender : oport +;; receiver : iport +;; server : string +;; port : number - (define-struct communicator (sender receiver server port)) +(define-struct communicator (sender receiver server port)) - ;; code : number - ;; text : string - ;; line : string - ;; communicator : communicator - ;; group : string - ;; article : number +;; code : number +;; text : string +;; line : string +;; communicator : communicator +;; group : string +;; article : number - (define-struct (nntp exn) ()) - (define-struct (unexpected-response nntp) (code text)) - (define-struct (bad-status-line nntp) (line)) - (define-struct (premature-close nntp) (communicator)) - (define-struct (bad-newsgroup-line nntp) (line)) - (define-struct (non-existent-group nntp) (group)) - (define-struct (article-not-in-group nntp) (article)) - (define-struct (no-group-selected nntp) ()) - (define-struct (article-not-found nntp) (article)) - (define-struct (authentication-rejected nntp) ()) +(define-struct (nntp exn) ()) +(define-struct (unexpected-response nntp) (code text)) +(define-struct (bad-status-line nntp) (line)) +(define-struct (premature-close nntp) (communicator)) +(define-struct (bad-newsgroup-line nntp) (line)) +(define-struct (non-existent-group nntp) (group)) +(define-struct (article-not-in-group nntp) (article)) +(define-struct (no-group-selected nntp) ()) +(define-struct (article-not-found nntp) (article)) +(define-struct (authentication-rejected nntp) ()) - ;; signal-error : - ;; (exn-args ... -> exn) x format-string x values ... -> - ;; exn-args -> () +;; signal-error : +;; (exn-args ... -> exn) x format-string x values ... -> +;; exn-args -> () - ;; - throws an exception +;; - throws an exception - (define (signal-error constructor format-string . args) - (lambda exn-args - (raise (apply constructor - (apply format format-string args) - (current-continuation-marks) - exn-args)))) +(define (signal-error constructor format-string . args) + (lambda exn-args + (raise (apply constructor + (apply format format-string args) + (current-continuation-marks) + exn-args)))) - ;; default-nntpd-port-number : - ;; number +;; default-nntpd-port-number : +;; number - (define default-nntpd-port-number 119) +(define default-nntpd-port-number 119) - ;; connect-to-server*: - ;; input-port output-port -> communicator +;; connect-to-server*: +;; input-port output-port -> communicator - (define connect-to-server* - (case-lambda - [(receiver sender) - (connect-to-server* receiver sender "unspecified" "unspecified")] - [(receiver sender server-name port-number) - (file-stream-buffer-mode sender 'line) - (let ([communicator (make-communicator sender receiver server-name - port-number)]) - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(200 201) communicator] - [else ((signal-error make-unexpected-response - "unexpected connection response: ~s ~s" - code response) - code response)])))])) +(define connect-to-server* + (case-lambda + [(receiver sender) + (connect-to-server* receiver sender "unspecified" "unspecified")] + [(receiver sender server-name port-number) + (file-stream-buffer-mode sender 'line) + (let ([communicator (make-communicator sender receiver server-name + port-number)]) + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(200 201) communicator] + [else ((signal-error make-unexpected-response + "unexpected connection response: ~s ~s" + code response) + code response)])))])) - ;; connect-to-server : - ;; string [x number] -> commnicator +;; connect-to-server : +;; string [x number] -> commnicator - (define connect-to-server - (opt-lambda (server-name (port-number default-nntpd-port-number)) - (let-values ([(receiver sender) - (tcp-connect server-name port-number)]) - (connect-to-server* receiver sender server-name port-number)))) +(define connect-to-server + (lambda (server-name (port-number default-nntpd-port-number)) + (let-values ([(receiver sender) + (tcp-connect server-name port-number)]) + (connect-to-server* receiver sender server-name port-number)))) - ;; close-communicator : - ;; communicator -> () +;; close-communicator : +;; communicator -> () - (define (close-communicator communicator) - (close-input-port (communicator-receiver communicator)) - (close-output-port (communicator-sender communicator))) +(define (close-communicator communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator))) - ;; disconnect-from-server : - ;; communicator -> () +;; disconnect-from-server : +;; communicator -> () - (define (disconnect-from-server communicator) - (send-to-server communicator "QUIT") - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(205) - (close-communicator communicator)] - [else - ((signal-error make-unexpected-response - "unexpected dis-connect response: ~s ~s" - code response) - code response)]))) +(define (disconnect-from-server communicator) + (send-to-server communicator "QUIT") + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(205) + (close-communicator communicator)] + [else + ((signal-error make-unexpected-response + "unexpected dis-connect response: ~s ~s" + code response) + code response)]))) - ;; authenticate-user : - ;; communicator x user-name x password -> () - ;; the password is not used if the server does not ask for it. +;; authenticate-user : +;; communicator x user-name x password -> () +;; the password is not used if the server does not ask for it. - (define (authenticate-user communicator user password) - (define (reject code response) - ((signal-error make-authentication-rejected - "authentication rejected (~s ~s)" - code response))) - (define (unexpected code response) - ((signal-error make-unexpected-response - "unexpected response for authentication: ~s ~s" - code response) - code response)) - (send-to-server communicator "AUTHINFO USER ~a" user) - (let-values ([(code response) (get-single-line-response communicator)]) - (case code - [(281) (void)] ; server doesn't ask for a password - [(381) - (send-to-server communicator "AUTHINFO PASS ~a" password) - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(281) (void)] ; done - [(502) (reject code response)] - [else (unexpected code response)]))] - [(502) (reject code response)] - [else (reject code response) - (unexpected code response)]))) +(define (authenticate-user communicator user password) + (define (reject code response) + ((signal-error make-authentication-rejected + "authentication rejected (~s ~s)" + code response))) + (define (unexpected code response) + ((signal-error make-unexpected-response + "unexpected response for authentication: ~s ~s" + code response) + code response)) + (send-to-server communicator "AUTHINFO USER ~a" user) + (let-values ([(code response) (get-single-line-response communicator)]) + (case code + [(281) (void)] ; server doesn't ask for a password + [(381) + (send-to-server communicator "AUTHINFO PASS ~a" password) + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(281) (void)] ; done + [(502) (reject code response)] + [else (unexpected code response)]))] + [(502) (reject code response)] + [else (reject code response) + (unexpected code response)]))) - ;; send-to-server : - ;; communicator x format-string x list (values) -> () +;; send-to-server : +;; communicator x format-string x list (values) -> () - (define (send-to-server communicator message-template . rest) - (let ([sender (communicator-sender communicator)]) - (apply fprintf sender - (string-append message-template "\r\n") - rest) - (flush-output sender))) +(define (send-to-server communicator message-template . rest) + (let ([sender (communicator-sender communicator)]) + (apply fprintf sender + (string-append message-template "\r\n") + rest) + (flush-output sender))) - ;; parse-status-line : - ;; string -> number x string +;; parse-status-line : +;; string -> number x string - (define (parse-status-line line) - (if (eof-object? line) +(define (parse-status-line line) + (if (eof-object? line) ((signal-error make-bad-status-line "eof instead of a status line") line) (let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line) @@ -154,99 +154,99 @@ (values (string->number (car match)) (cadr match))))) - ;; get-one-line-from-server : - ;; iport -> string +;; get-one-line-from-server : +;; iport -> string - (define (get-one-line-from-server server->client-port) - (read-line server->client-port 'return-linefeed)) +(define (get-one-line-from-server server->client-port) + (read-line server->client-port 'return-linefeed)) - ;; get-single-line-response : - ;; communicator -> number x string +;; get-single-line-response : +;; communicator -> number x string - (define (get-single-line-response communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)]) - (parse-status-line status-line))) +(define (get-single-line-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)]) + (parse-status-line status-line))) - ;; get-rest-of-multi-line-response : - ;; communicator -> list (string) +;; get-rest-of-multi-line-response : +;; communicator -> list (string) - (define (get-rest-of-multi-line-response communicator) - (let ([receiver (communicator-receiver communicator)]) - (let loop () - (let ([l (get-one-line-from-server receiver)]) - (cond - [(eof-object? l) - ((signal-error make-premature-close - "port prematurely closed during multi-line response") - communicator)] - [(string=? l ".") - '()] - [(string=? l "..") - (cons "." (loop))] - [else - (cons l (loop))]))))) +(define (get-rest-of-multi-line-response communicator) + (let ([receiver (communicator-receiver communicator)]) + (let loop () + (let ([l (get-one-line-from-server receiver)]) + (cond + [(eof-object? l) + ((signal-error make-premature-close + "port prematurely closed during multi-line response") + communicator)] + [(string=? l ".") + '()] + [(string=? l "..") + (cons "." (loop))] + [else + (cons l (loop))]))))) - ;; get-multi-line-response : - ;; communicator -> number x string x list (string) +;; get-multi-line-response : +;; communicator -> number x string x list (string) - ;; -- The returned values are the status code, the rest of the status - ;; response line, and the remaining lines. +;; -- The returned values are the status code, the rest of the status +;; response line, and the remaining lines. - (define (get-multi-line-response communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)]) - (let-values ([(code rest-of-line) - (parse-status-line status-line)]) - (values code rest-of-line (get-rest-of-multi-line-response))))) - - ;; open-news-group : - ;; communicator x string -> number x number x number - - ;; -- The returned values are the number of articles, the first - ;; article number, and the last article number for that group. - - (define (open-news-group communicator group-name) - (send-to-server communicator "GROUP ~a" group-name) +(define (get-multi-line-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)]) (let-values ([(code rest-of-line) - (get-single-line-response communicator)]) - (case code - [(211) - (let ([match (map string->number - (cdr - (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line) - ((signal-error make-bad-newsgroup-line - "malformed newsgroup open response: ~s" - rest-of-line) - rest-of-line))))]) - (let ([number-of-articles (car match)] - [first-article-number (cadr match)] - [last-article-number (caddr match)]) - (values number-of-articles - first-article-number - last-article-number)))] - [(411) - ((signal-error make-non-existent-group - "group ~s does not exist on server ~s" - group-name (communicator-server communicator)) - group-name)] - [else - ((signal-error make-unexpected-response - "unexpected group opening response: ~s" code) - code rest-of-line)]))) + (parse-status-line status-line)]) + (values code rest-of-line (get-rest-of-multi-line-response))))) - ;; generic-message-command : - ;; string x number -> communicator x (number U string) -> list (string) +;; open-news-group : +;; communicator x string -> number x number x number - (define (generic-message-command command ok-code) - (lambda (communicator message-index) - (send-to-server communicator (string-append command " ~a") - (if (number? message-index) +;; -- The returned values are the number of articles, the first +;; article number, and the last article number for that group. + +(define (open-news-group communicator group-name) + (send-to-server communicator "GROUP ~a" group-name) + (let-values ([(code rest-of-line) + (get-single-line-response communicator)]) + (case code + [(211) + (let ([match (map string->number + (cdr + (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line) + ((signal-error make-bad-newsgroup-line + "malformed newsgroup open response: ~s" + rest-of-line) + rest-of-line))))]) + (let ([number-of-articles (car match)] + [first-article-number (cadr match)] + [last-article-number (caddr match)]) + (values number-of-articles + first-article-number + last-article-number)))] + [(411) + ((signal-error make-non-existent-group + "group ~s does not exist on server ~s" + group-name (communicator-server communicator)) + group-name)] + [else + ((signal-error make-unexpected-response + "unexpected group opening response: ~s" code) + code rest-of-line)]))) + +;; generic-message-command : +;; string x number -> communicator x (number U string) -> list (string) + +(define (generic-message-command command ok-code) + (lambda (communicator message-index) + (send-to-server communicator (string-append command " ~a") + (if (number? message-index) (number->string message-index) message-index)) - (let-values ([(code response) - (get-single-line-response communicator)]) - (if (= code ok-code) + (let-values ([(code response) + (get-single-line-response communicator)]) + (if (= code ok-code) (get-rest-of-multi-line-response communicator) (case code [(423) @@ -265,54 +265,54 @@ "unexpected message access response: ~s" code) code response)]))))) - ;; head-of-message : - ;; communicator x (number U string) -> list (string) +;; head-of-message : +;; communicator x (number U string) -> list (string) - (define head-of-message - (generic-message-command "HEAD" 221)) +(define head-of-message + (generic-message-command "HEAD" 221)) - ;; body-of-message : - ;; communicator x (number U string) -> list (string) +;; body-of-message : +;; communicator x (number U string) -> list (string) - (define body-of-message - (generic-message-command "BODY" 222)) +(define body-of-message + (generic-message-command "BODY" 222)) - ;; newnews-since : - ;; communicator x (number U string) -> list (string) +;; newnews-since : +;; communicator x (number U string) -> list (string) - (define newnews-since - (generic-message-command "NEWNEWS" 230)) +(define newnews-since + (generic-message-command "NEWNEWS" 230)) - ;; make-desired-header : - ;; string -> desired +;; make-desired-header : +;; string -> desired - (define (make-desired-header raw-header) - (regexp - (string-append - "^" - (list->string - (apply append - (map (lambda (c) - (cond - [(char-lower-case? c) - (list #\[ (char-upcase c) c #\])] - [(char-upper-case? c) - (list #\[ c (char-downcase c) #\])] - [else - (list c)])) - (string->list raw-header)))) - ":"))) +(define (make-desired-header raw-header) + (regexp + (string-append + "^" + (list->string + (apply append + (map (lambda (c) + (cond + [(char-lower-case? c) + (list #\[ (char-upcase c) c #\])] + [(char-upper-case? c) + (list #\[ c (char-downcase c) #\])] + [else + (list c)])) + (string->list raw-header)))) + ":"))) - ;; extract-desired-headers : - ;; list (string) x list (desired) -> list (string) +;; extract-desired-headers : +;; list (string) x list (desired) -> list (string) - (define (extract-desired-headers headers desireds) - (let loop ([headers headers]) - (if (null? headers) null - (let ([first (car headers)] - [rest (cdr headers)]) - (if (ormap (lambda (matcher) - (regexp-match matcher first)) - desireds) +(define (extract-desired-headers headers desireds) + (let loop ([headers headers]) + (if (null? headers) null + (let ([first (car headers)] + [rest (cdr headers)]) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) (cons first (loop rest)) (loop rest)))))) diff --git a/collects/net/pop3-unit.ss b/collects/net/pop3-unit.ss index b68e873..c4f0603 100644 --- a/collects/net/pop3-unit.ss +++ b/collects/net/pop3-unit.ss @@ -1,390 +1,390 @@ #lang scheme/unit - (require (lib "etc.ss") "pop3-sig.ss") +(require scheme/tcp "pop3-sig.ss") - (import) - (export pop3^) +(import) +(export pop3^) - ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose +;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose - ;; sender : oport - ;; receiver : iport - ;; server : string - ;; port : number - ;; state : symbol = (disconnected, authorization, transaction) +;; sender : oport +;; receiver : iport +;; server : string +;; port : number +;; state : symbol = (disconnected, authorization, transaction) - (define-struct communicator (sender receiver server port state)) +(define-struct communicator (sender receiver server port [state #:mutable])) - (define-struct (pop3 exn) ()) - (define-struct (cannot-connect pop3) ()) - (define-struct (username-rejected pop3) ()) - (define-struct (password-rejected pop3) ()) - (define-struct (not-ready-for-transaction pop3) (communicator)) - (define-struct (not-given-headers pop3) (communicator message)) - (define-struct (illegal-message-number pop3) (communicator message)) - (define-struct (cannot-delete-message exn) (communicator message)) - (define-struct (disconnect-not-quiet pop3) (communicator)) - (define-struct (malformed-server-response pop3) (communicator)) +(define-struct (pop3 exn) ()) +(define-struct (cannot-connect pop3) ()) +(define-struct (username-rejected pop3) ()) +(define-struct (password-rejected pop3) ()) +(define-struct (not-ready-for-transaction pop3) (communicator)) +(define-struct (not-given-headers pop3) (communicator message)) +(define-struct (illegal-message-number pop3) (communicator message)) +(define-struct (cannot-delete-message exn) (communicator message)) +(define-struct (disconnect-not-quiet pop3) (communicator)) +(define-struct (malformed-server-response pop3) (communicator)) - ;; signal-error : - ;; (exn-args ... -> exn) x format-string x values ... -> - ;; exn-args -> () +;; signal-error : +;; (exn-args ... -> exn) x format-string x values ... -> +;; exn-args -> () - (define (signal-error constructor format-string . args) - (lambda exn-args - (raise (apply constructor - (apply format format-string args) - (current-continuation-marks) - exn-args)))) +(define (signal-error constructor format-string . args) + (lambda exn-args + (raise (apply constructor + (apply format format-string args) + (current-continuation-marks) + exn-args)))) - ;; signal-malformed-response-error : - ;; exn-args -> () +;; signal-malformed-response-error : +;; exn-args -> () - ;; -- in practice, it takes only one argument: a communicator. +;; -- in practice, it takes only one argument: a communicator. - (define signal-malformed-response-error - (signal-error make-malformed-server-response - "malformed response from server")) +(define signal-malformed-response-error + (signal-error make-malformed-server-response + "malformed response from server")) - ;; confirm-transaction-mode : - ;; communicator x string -> () +;; confirm-transaction-mode : +;; communicator x string -> () - ;; -- signals an error otherwise. +;; -- signals an error otherwise. - (define (confirm-transaction-mode communicator error-message) - (unless (eq? (communicator-state communicator) 'transaction) - ((signal-error make-not-ready-for-transaction error-message) - communicator))) +(define (confirm-transaction-mode communicator error-message) + (unless (eq? (communicator-state communicator) 'transaction) + ((signal-error make-not-ready-for-transaction error-message) + communicator))) - ;; default-pop-port-number : - ;; number +;; default-pop-port-number : +;; number - (define default-pop-port-number 110) +(define default-pop-port-number 110) - (define-struct server-responses ()) - (define-struct (+ok server-responses) ()) - (define-struct (-err server-responses) ()) +(define-struct server-responses ()) +(define-struct (+ok server-responses) ()) +(define-struct (-err server-responses) ()) - ;; connect-to-server*: - ;; input-port output-port -> communicator +;; connect-to-server*: +;; input-port output-port -> communicator - (define connect-to-server* - (case-lambda - [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")] - [(receiver sender server-name port-number) - (let ([communicator (make-communicator sender receiver server-name port-number - 'authorization)]) - (let ([response (get-status-response/basic communicator)]) - (cond - [(+ok? response) communicator] - [(-err? response) - ((signal-error make-cannot-connect - "cannot connect to ~a on port ~a" - server-name port-number))])))])) - - ;; connect-to-server : - ;; string [x number] -> communicator - - (define connect-to-server - (opt-lambda (server-name (port-number default-pop-port-number)) - (let-values ([(receiver sender) (tcp-connect server-name port-number)]) - (connect-to-server* receiver sender server-name port-number)))) - - ;; authenticate/plain-text : - ;; string x string x communicator -> () - - ;; -- if authentication succeeds, sets the communicator's state to - ;; transaction. - - (define (authenticate/plain-text username password communicator) - (let ([sender (communicator-sender communicator)]) - (send-to-server communicator "USER ~a" username) - (let ([status (get-status-response/basic communicator)]) +(define connect-to-server* + (case-lambda + [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")] + [(receiver sender server-name port-number) + (let ([communicator (make-communicator sender receiver server-name port-number + 'authorization)]) + (let ([response (get-status-response/basic communicator)]) (cond - [(+ok? status) - (send-to-server communicator "PASS ~a" password) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (set-communicator-state! communicator 'transaction)] - [(-err? status) - ((signal-error make-password-rejected - "password was rejected"))]))] - [(-err? status) - ((signal-error make-username-rejected - "username was rejected"))])))) + [(+ok? response) communicator] + [(-err? response) + ((signal-error make-cannot-connect + "cannot connect to ~a on port ~a" + server-name port-number))])))])) - ;; get-mailbox-status : - ;; communicator -> number x number +;; connect-to-server : +;; string [x number] -> communicator - ;; -- returns number of messages and number of octets. +(define connect-to-server + (lambda (server-name (port-number default-pop-port-number)) + (let-values ([(receiver sender) (tcp-connect server-name port-number)]) + (connect-to-server* receiver sender server-name port-number)))) - (define (get-mailbox-status communicator) - (confirm-transaction-mode - communicator - "cannot get mailbox status unless in transaction mode") - (send-to-server communicator "STAT") - (apply values - (map string->number - (let-values ([(status result) - (get-status-response/match - communicator - #rx"([0-9]+) ([0-9]+)" - #f)]) - result)))) +;; authenticate/plain-text : +;; string x string x communicator -> () - ;; get-message/complete : - ;; communicator x number -> list (string) x list (string) +;; -- if authentication succeeds, sets the communicator's state to +;; transaction. - (define (get-message/complete communicator message) - (confirm-transaction-mode - communicator - "cannot get message headers unless in transaction state") - (send-to-server communicator "RETR ~a" message) +(define (authenticate/plain-text username password communicator) + (let ([sender (communicator-sender communicator)]) + (send-to-server communicator "USER ~a" username) (let ([status (get-status-response/basic communicator)]) (cond - [(+ok? status) - (split-header/body (get-multi-line-response communicator))] - [(-err? status) - ((signal-error make-illegal-message-number - "not given message ~a" message) - communicator message)]))) + [(+ok? status) + (send-to-server communicator "PASS ~a" password) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (set-communicator-state! communicator 'transaction)] + [(-err? status) + ((signal-error make-password-rejected + "password was rejected"))]))] + [(-err? status) + ((signal-error make-username-rejected + "username was rejected"))])))) - ;; get-message/headers : - ;; communicator x number -> list (string) +;; get-mailbox-status : +;; communicator -> number x number - (define (get-message/headers communicator message) - (confirm-transaction-mode - communicator - "cannot get message headers unless in transaction state") - (send-to-server communicator "TOP ~a 0" message) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (let-values ([(headers body) - (split-header/body - (get-multi-line-response communicator))]) - headers)] - [(-err? status) - ((signal-error make-not-given-headers - "not given headers to message ~a" message) - communicator message)]))) +;; -- returns number of messages and number of octets. - ;; get-message/body : - ;; communicator x number -> list (string) +(define (get-mailbox-status communicator) + (confirm-transaction-mode + communicator + "cannot get mailbox status unless in transaction mode") + (send-to-server communicator "STAT") + (apply values + (map string->number + (let-values ([(status result) + (get-status-response/match + communicator + #rx"([0-9]+) ([0-9]+)" + #f)]) + result)))) - (define (get-message/body communicator message) - (let-values ([(headers body) (get-message/complete communicator message)]) - body)) +;; get-message/complete : +;; communicator x number -> list (string) x list (string) - ;; split-header/body : - ;; list (string) -> list (string) x list (string) +(define (get-message/complete communicator message) + (confirm-transaction-mode + communicator + "cannot get message headers unless in transaction state") + (send-to-server communicator "RETR ~a" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (split-header/body (get-multi-line-response communicator))] + [(-err? status) + ((signal-error make-illegal-message-number + "not given message ~a" message) + communicator message)]))) - ;; -- returns list of headers and list of body lines. +;; get-message/headers : +;; communicator x number -> list (string) - (define (split-header/body lines) - (let loop ([lines lines] [header null]) - (if (null? lines) +(define (get-message/headers communicator message) + (confirm-transaction-mode + communicator + "cannot get message headers unless in transaction state") + (send-to-server communicator "TOP ~a 0" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (let-values ([(headers body) + (split-header/body + (get-multi-line-response communicator))]) + headers)] + [(-err? status) + ((signal-error make-not-given-headers + "not given headers to message ~a" message) + communicator message)]))) + +;; get-message/body : +;; communicator x number -> list (string) + +(define (get-message/body communicator message) + (let-values ([(headers body) (get-message/complete communicator message)]) + body)) + +;; split-header/body : +;; list (string) -> list (string) x list (string) + +;; -- returns list of headers and list of body lines. + +(define (split-header/body lines) + (let loop ([lines lines] [header null]) + (if (null? lines) (values (reverse header) null) (let ([first (car lines)] [rest (cdr lines)]) (if (string=? first "") - (values (reverse header) rest) - (loop rest (cons first header))))))) + (values (reverse header) rest) + (loop rest (cons first header))))))) - ;; delete-message : - ;; communicator x number -> () +;; delete-message : +;; communicator x number -> () - (define (delete-message communicator message) - (confirm-transaction-mode - communicator - "cannot delete message unless in transaction state") - (send-to-server communicator "DELE ~a" message) - (let ([status (get-status-response/basic communicator)]) - (cond - [(-err? status) - ((signal-error make-cannot-delete-message - "no message numbered ~a available to be deleted" message) - communicator message)] - [(+ok? status) - 'deleted]))) +(define (delete-message communicator message) + (confirm-transaction-mode + communicator + "cannot delete message unless in transaction state") + (send-to-server communicator "DELE ~a" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(-err? status) + ((signal-error make-cannot-delete-message + "no message numbered ~a available to be deleted" message) + communicator message)] + [(+ok? status) + 'deleted]))) - ;; regexp for UIDL responses +;; regexp for UIDL responses - (define uidl-regexp #rx"([0-9]+) (.*)") +(define uidl-regexp #rx"([0-9]+) (.*)") - ;; get-unique-id/single : - ;; communicator x number -> string +;; get-unique-id/single : +;; communicator x number -> string - (define (get-unique-id/single communicator message) - (confirm-transaction-mode - communicator - "cannot get unique message id unless in transaction state") - (send-to-server communicator "UIDL ~a" message) - (let-values ([(status result) - (get-status-response/match communicator uidl-regexp ".*")]) - ;; The server response is of the form - ;; +OK 2 QhdPYR:00WBw1Ph7x7 - (cond - [(-err? status) - ((signal-error make-illegal-message-number - "no message numbered ~a available for unique id" message) - communicator message)] - [(+ok? status) - (cadr result)]))) +(define (get-unique-id/single communicator message) + (confirm-transaction-mode + communicator + "cannot get unique message id unless in transaction state") + (send-to-server communicator "UIDL ~a" message) + (let-values ([(status result) + (get-status-response/match communicator uidl-regexp ".*")]) + ;; The server response is of the form + ;; +OK 2 QhdPYR:00WBw1Ph7x7 + (cond + [(-err? status) + ((signal-error make-illegal-message-number + "no message numbered ~a available for unique id" message) + communicator message)] + [(+ok? status) + (cadr result)]))) - ;; get-unique-id/all : - ;; communicator -> list(number x string) +;; get-unique-id/all : +;; communicator -> list(number x string) - (define (get-unique-id/all communicator) - (confirm-transaction-mode communicator - "cannot get unique message ids unless in transaction state") - (send-to-server communicator "UIDL") - (let ([status (get-status-response/basic communicator)]) - ;; The server response is of the form - ;; +OK - ;; 1 whqtswO00WBw418f9t5JxYwZ - ;; 2 QhdPYR:00WBw1Ph7x7 - ;; . - (map (lambda (l) - (let ([m (regexp-match uidl-regexp l)]) - (cons (string->number (cadr m)) (caddr m)))) - (get-multi-line-response communicator)))) +(define (get-unique-id/all communicator) + (confirm-transaction-mode communicator + "cannot get unique message ids unless in transaction state") + (send-to-server communicator "UIDL") + (let ([status (get-status-response/basic communicator)]) + ;; The server response is of the form + ;; +OK + ;; 1 whqtswO00WBw418f9t5JxYwZ + ;; 2 QhdPYR:00WBw1Ph7x7 + ;; . + (map (lambda (l) + (let ([m (regexp-match uidl-regexp l)]) + (cons (string->number (cadr m)) (caddr m)))) + (get-multi-line-response communicator)))) - ;; close-communicator : - ;; communicator -> () +;; close-communicator : +;; communicator -> () - (define (close-communicator communicator) - (close-input-port (communicator-receiver communicator)) - (close-output-port (communicator-sender communicator))) +(define (close-communicator communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator))) - ;; disconnect-from-server : - ;; communicator -> () +;; disconnect-from-server : +;; communicator -> () - (define (disconnect-from-server communicator) - (send-to-server communicator "QUIT") - (set-communicator-state! communicator 'disconnected) - (let ([response (get-status-response/basic communicator)]) - (close-communicator communicator) - (cond - [(+ok? response) (void)] - [(-err? response) - ((signal-error make-disconnect-not-quiet - "got error status upon disconnect") - communicator)]))) +(define (disconnect-from-server communicator) + (send-to-server communicator "QUIT") + (set-communicator-state! communicator 'disconnected) + (let ([response (get-status-response/basic communicator)]) + (close-communicator communicator) + (cond + [(+ok? response) (void)] + [(-err? response) + ((signal-error make-disconnect-not-quiet + "got error status upon disconnect") + communicator)]))) - ;; send-to-server : - ;; communicator x format-string x list (values) -> () +;; send-to-server : +;; communicator x format-string x list (values) -> () - (define (send-to-server communicator message-template . rest) - (apply fprintf (communicator-sender communicator) - (string-append message-template "\r\n") - rest) - (flush-output (communicator-sender communicator))) +(define (send-to-server communicator message-template . rest) + (apply fprintf (communicator-sender communicator) + (string-append message-template "\r\n") + rest) + (flush-output (communicator-sender communicator))) - ;; get-one-line-from-server : - ;; iport -> string +;; get-one-line-from-server : +;; iport -> string - (define (get-one-line-from-server server->client-port) - (read-line server->client-port 'return-linefeed)) +(define (get-one-line-from-server server->client-port) + (read-line server->client-port 'return-linefeed)) - ;; get-server-status-response : - ;; communicator -> server-responses x string +;; get-server-status-response : +;; communicator -> server-responses x string - ;; -- provides the low-level functionality of checking for +OK - ;; and -ERR, returning an appropriate structure, and returning the - ;; rest of the status response as a string to be used for further - ;; parsing, if necessary. +;; -- provides the low-level functionality of checking for +OK +;; and -ERR, returning an appropriate structure, and returning the +;; rest of the status response as a string to be used for further +;; parsing, if necessary. - (define (get-server-status-response communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)] - [r (regexp-match #rx"^\\+OK(.*)" status-line)]) - (if r +(define (get-server-status-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)] + [r (regexp-match #rx"^\\+OK(.*)" status-line)]) + (if r (values (make-+ok) (cadr r)) (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)]) (if r - (values (make--err) (cadr r)) - (signal-malformed-response-error communicator)))))) + (values (make--err) (cadr r)) + (signal-malformed-response-error communicator)))))) - ;; get-status-response/basic : - ;; communicator -> server-responses +;; get-status-response/basic : +;; communicator -> server-responses - ;; -- when the only thing to determine is whether the response - ;; was +OK or -ERR. +;; -- when the only thing to determine is whether the response +;; was +OK or -ERR. - (define (get-status-response/basic communicator) - (let-values ([(response rest) - (get-server-status-response communicator)]) - response)) +(define (get-status-response/basic communicator) + (let-values ([(response rest) + (get-server-status-response communicator)]) + response)) - ;; get-status-response/match : - ;; communicator x regexp x regexp -> (status x list (string)) +;; get-status-response/match : +;; communicator x regexp x regexp -> (status x list (string)) - ;; -- when further parsing of the status response is necessary. - ;; Strips off the car of response from regexp-match. +;; -- when further parsing of the status response is necessary. +;; Strips off the car of response from regexp-match. - (define (get-status-response/match communicator +regexp -regexp) - (let-values ([(response rest) - (get-server-status-response communicator)]) - (if (and +regexp (+ok? response)) +(define (get-status-response/match communicator +regexp -regexp) + (let-values ([(response rest) + (get-server-status-response communicator)]) + (if (and +regexp (+ok? response)) (let ([r (regexp-match +regexp rest)]) (if r (values response (cdr r)) (signal-malformed-response-error communicator))) (if (and -regexp (-err? response)) - (let ([r (regexp-match -regexp rest)]) - (if r (values response (cdr r)) - (signal-malformed-response-error communicator))) - (signal-malformed-response-error communicator))))) + (let ([r (regexp-match -regexp rest)]) + (if r (values response (cdr r)) + (signal-malformed-response-error communicator))) + (signal-malformed-response-error communicator))))) - ;; get-multi-line-response : - ;; communicator -> list (string) +;; get-multi-line-response : +;; communicator -> list (string) - (define (get-multi-line-response communicator) - (let ([receiver (communicator-receiver communicator)]) - (let loop () - (let ([l (get-one-line-from-server receiver)]) - (cond - [(eof-object? l) - (signal-malformed-response-error communicator)] - [(string=? l ".") - '()] - [(and (> (string-length l) 1) - (char=? (string-ref l 0) #\.)) - (cons (substring l 1 (string-length l)) (loop))] - [else - (cons l (loop))]))))) +(define (get-multi-line-response communicator) + (let ([receiver (communicator-receiver communicator)]) + (let loop () + (let ([l (get-one-line-from-server receiver)]) + (cond + [(eof-object? l) + (signal-malformed-response-error communicator)] + [(string=? l ".") + '()] + [(and (> (string-length l) 1) + (char=? (string-ref l 0) #\.)) + (cons (substring l 1 (string-length l)) (loop))] + [else + (cons l (loop))]))))) - ;; make-desired-header : - ;; string -> desired +;; make-desired-header : +;; string -> desired - (define (make-desired-header raw-header) - (regexp - (string-append - "^" - (list->string - (apply append - (map (lambda (c) - (cond - [(char-lower-case? c) - (list #\[ (char-upcase c) c #\])] - [(char-upper-case? c) - (list #\[ c (char-downcase c) #\])] - [else - (list c)])) - (string->list raw-header)))) - ":"))) +(define (make-desired-header raw-header) + (regexp + (string-append + "^" + (list->string + (apply append + (map (lambda (c) + (cond + [(char-lower-case? c) + (list #\[ (char-upcase c) c #\])] + [(char-upper-case? c) + (list #\[ c (char-downcase c) #\])] + [else + (list c)])) + (string->list raw-header)))) + ":"))) - ;; extract-desired-headers : - ;; list (string) x list (desired) -> list (string) +;; extract-desired-headers : +;; list (string) x list (desired) -> list (string) - (define (extract-desired-headers headers desireds) - (let loop ([headers headers]) - (if (null? headers) null - (let ([first (car headers)] - [rest (cdr headers)]) - (if (ormap (lambda (matcher) - (regexp-match matcher first)) - desireds) +(define (extract-desired-headers headers desireds) + (let loop ([headers headers]) + (if (null? headers) null + (let ([first (car headers)] + [rest (cdr headers)]) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) (cons first (loop rest)) (loop rest)))))) diff --git a/collects/net/qp-sig.ss b/collects/net/qp-sig.ss index b240760..26a76e5 100644 --- a/collects/net/qp-sig.ss +++ b/collects/net/qp-sig.ss @@ -1,9 +1,9 @@ #lang scheme/signature ;; -- exceptions raised -- -(struct qp-error () -setters -constructor) -(struct qp-wrong-input () -setters -constructor) -(struct qp-wrong-line-size (size) -setters -constructor) +(struct qp-error () #:omit-constructor) +(struct qp-wrong-input () #:omit-constructor) +(struct qp-wrong-line-size (size) #:omit-constructor) ;; -- qp methods -- qp-encode diff --git a/collects/net/smtp-unit.ss b/collects/net/smtp-unit.ss index fc58f4a..9c14319 100644 --- a/collects/net/smtp-unit.ss +++ b/collects/net/smtp-unit.ss @@ -1,26 +1,27 @@ #lang scheme/unit - (require (lib "list.ss") (lib "kw.ss") "base64.ss" "smtp-sig.ss") - (import) - (export smtp^) +(require scheme/tcp "base64.ss" "smtp-sig.ss") - (define smtp-sending-server (make-parameter "localhost")) +(import) +(export smtp^) - (define debug-via-stdio? #f) +(define smtp-sending-server (make-parameter "localhost")) - (define (log . args) - ;; (apply printf args) - (void)) +(define debug-via-stdio? #f) - (define (starts-with? l n) - (and (>= (string-length l) (string-length n)) - (string=? n (substring l 0 (string-length n))))) +(define (log . args) + ;; (apply printf args) + (void)) - (define (check-reply/accum r v w a) - (flush-output w) - (let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))]) - (log "server: ~a\n" l) - (if (eof-object? l) +(define (starts-with? l n) + (and (>= (string-length l) (string-length n)) + (string=? n (substring l 0 (string-length n))))) + +(define (check-reply/accum r v w a) + (flush-output w) + (let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))]) + (log "server: ~a\n" l) + (if (eof-object? l) (error 'check-reply "got EOF") (let ([n (number->string v)]) (unless (starts-with? l n) @@ -32,135 +33,133 @@ ;; We're finished, so add the last and reverse the result (when a (reverse (cons (substring l 4) a))))))))) - - (define (check-reply/commands r v w . commands) - ;; drop the first response, which is just the flavor text -- we expect the rest to - ;; be a list of supported ESMTP commands. - (let ([cmdlist (rest (check-reply/accum r v w '()))]) - (for-each (lambda (c1) - (unless (findf (lambda (c2) (string=? c1 c2)) cmdlist) - (error "expected advertisement of ESMTP command ~a" c1))) - commands))) - - (define (check-reply r v w) - (check-reply/accum r v w #f)) - (define (protect-line l) - ;; If begins with a dot, add one more - (if (or (equal? l #"") - (equal? l "") - (and (string? l) - (not (char=? #\. (string-ref l 0)))) - (and (bytes? l) - (not (= (char->integer #\.) (bytes-ref l 0))))) +(define (check-reply/commands r v w . commands) + ;; drop the first response, which is just the flavor text -- we expect the rest to + ;; be a list of supported ESMTP commands. + (let ([cmdlist (cdr (check-reply/accum r v w '()))]) + (for-each (lambda (c1) + (unless (findf (lambda (c2) (string=? c1 c2)) cmdlist) + (error "expected advertisement of ESMTP command ~a" c1))) + commands))) + +(define (check-reply r v w) + (check-reply/accum r v w #f)) + +(define (protect-line l) + ;; If begins with a dot, add one more + (if (or (equal? l #"") + (equal? l "") + (and (string? l) + (not (char=? #\. (string-ref l 0)))) + (and (bytes? l) + (not (= (char->integer #\.) (bytes-ref l 0))))) l (if (bytes? l) - (bytes-append #"." l) - (string-append "." l)))) + (bytes-append #"." l) + (string-append "." l)))) - (define smtp-sending-end-of-message - (make-parameter void - (lambda (f) - (unless (and (procedure? f) - (procedure-arity-includes? f 0)) - (raise-type-error 'smtp-sending-end-of-message "thunk" f)) - f))) +(define smtp-sending-end-of-message + (make-parameter void + (lambda (f) + (unless (and (procedure? f) + (procedure-arity-includes? f 0)) + (raise-type-error 'smtp-sending-end-of-message "thunk" f)) + f))) - (define (smtp-send-message* r w sender recipients header message-lines - auth-user auth-passwd tls-encode) - (with-handlers ([void (lambda (x) - (close-input-port r) - (close-output-port w) - (raise x))]) +(define (smtp-send-message* r w sender recipients header message-lines + auth-user auth-passwd tls-encode) + (with-handlers ([void (lambda (x) + (close-input-port r) + (close-output-port w) + (raise x))]) + (check-reply r 220 w) + (log "hello\n") + (fprintf w "EHLO ~a\r\n" (smtp-sending-server)) + (when tls-encode + (check-reply/commands r 250 w "STARTTLS") + (log "starttls\n") + (fprintf w "STARTTLS\r\n") (check-reply r 220 w) - (log "hello\n") - (fprintf w "EHLO ~a\r\n" (smtp-sending-server)) - (when tls-encode - (check-reply/commands r 250 w "STARTTLS") - (log "starttls\n") - (fprintf w "STARTTLS\r\n") - (check-reply r 220 w) - (let-values ([(ssl-r ssl-w) - (tls-encode r w - #:mode 'connect - #:encrypt 'tls - #:close-original? #t)]) - (set! r ssl-r) - (set! w ssl-w)) - ;; According to RFC 3207 Sec 4.2, we must start anew with the EHLO. - (log "tls hello\n") - (fprintf w "EHLO ~a\r\n" (smtp-sending-server))) - (check-reply r 250 w) + (let-values ([(ssl-r ssl-w) + (tls-encode r w + #:mode 'connect + #:encrypt 'tls + #:close-original? #t)]) + (set! r ssl-r) + (set! w ssl-w)) + ;; According to RFC 3207 Sec 4.2, we must start anew with the EHLO. + (log "tls hello\n") + (fprintf w "EHLO ~a\r\n" (smtp-sending-server))) + (check-reply r 250 w) - (when auth-user - (log "auth\n") - (fprintf w "AUTH PLAIN ~a" - ;; Encoding adds CRLF - (base64-encode - (string->bytes/latin-1 - (format "~a\0~a\0~a" auth-user auth-user auth-passwd)))) - (check-reply r 235 w)) + (when auth-user + (log "auth\n") + (fprintf w "AUTH PLAIN ~a" + ;; Encoding adds CRLF + (base64-encode + (string->bytes/latin-1 + (format "~a\0~a\0~a" auth-user auth-user auth-passwd)))) + (check-reply r 235 w)) - (log "from\n") - (fprintf w "MAIL FROM:<~a>\r\n" sender) - (check-reply r 250 w) + (log "from\n") + (fprintf w "MAIL FROM:<~a>\r\n" sender) + (check-reply r 250 w) - (log "to\n") - (for-each - (lambda (dest) - (fprintf w "RCPT TO:<~a>\r\n" dest) - (check-reply r 250 w)) - recipients) + (log "to\n") + (for-each + (lambda (dest) + (fprintf w "RCPT TO:<~a>\r\n" dest) + (check-reply r 250 w)) + recipients) - (log "header\n") - (fprintf w "DATA\r\n") - (check-reply r 354 w) - (fprintf w "~a" header) - (for-each - (lambda (l) - (log "body: ~a\n" l) - (fprintf w "~a\r\n" (protect-line l))) - message-lines) + (log "header\n") + (fprintf w "DATA\r\n") + (check-reply r 354 w) + (fprintf w "~a" header) + (for-each + (lambda (l) + (log "body: ~a\n" l) + (fprintf w "~a\r\n" (protect-line l))) + message-lines) - ;; After we send the ".", then only break in an emergency - ((smtp-sending-end-of-message)) + ;; After we send the ".", then only break in an emergency + ((smtp-sending-end-of-message)) - (log "dot\n") - (fprintf w ".\r\n") - (flush-output w) - (check-reply r 250 w) + (log "dot\n") + (fprintf w ".\r\n") + (flush-output w) + (check-reply r 250 w) - ;; Once a 250 has been received in response to the . at the end of - ;; the DATA block, the email has been sent successfully and out of our - ;; hands. This function should thus indicate success at this point - ;; no matter what else happens. - ;; - ;; Some servers (like smtp.gmail.com) will just close the connection - ;; on a QUIT, so instead of causing any QUIT errors to look like the - ;; email failed, we'll just log them. - (with-handlers ([void (lambda (x) - (log "error after send: ~a\n" (exn-message x)))]) - (log "quit\n") - (fprintf w "QUIT\r\n") - (check-reply r 221 w)) + ;; Once a 250 has been received in response to the . at the end of + ;; the DATA block, the email has been sent successfully and out of our + ;; hands. This function should thus indicate success at this point + ;; no matter what else happens. + ;; + ;; Some servers (like smtp.gmail.com) will just close the connection + ;; on a QUIT, so instead of causing any QUIT errors to look like the + ;; email failed, we'll just log them. + (with-handlers ([void (lambda (x) + (log "error after send: ~a\n" (exn-message x)))]) + (log "quit\n") + (fprintf w "QUIT\r\n") + (check-reply r 221 w)) - (close-output-port w) - (close-input-port r))) + (close-output-port w) + (close-input-port r))) - (define smtp-send-message - (lambda/kw (server sender recipients header message-lines - #:key - [port-no 25] - [auth-user #f] - [auth-passwd #f] - [tcp-connect tcp-connect] - [tls-encode #f] - #:body - (#:optional [opt-port-no port-no])) - (when (null? recipients) - (error 'send-smtp-message "no receivers")) - (let-values ([(r w) (if debug-via-stdio? - (values (current-input-port) (current-output-port)) - (tcp-connect server opt-port-no))]) - (smtp-send-message* r w sender recipients header message-lines - auth-user auth-passwd tls-encode)))) +(define smtp-send-message + (lambda (server sender recipients header message-lines + #:port-no [port-no 25] + #:auth-user [auth-user #f] + #:auth-passwd [auth-passwd #f] + #:tcp-connect [tcp-connect tcp-connect] + #:tls-encode [tls-encode #f] + [opt-port-no port-no]) + (when (null? recipients) + (error 'send-smtp-message "no receivers")) + (let-values ([(r w) (if debug-via-stdio? + (values (current-input-port) (current-output-port)) + (tcp-connect server opt-port-no))]) + (smtp-send-message* r w sender recipients header message-lines + auth-user auth-passwd tls-encode))))