change scheme/unit and scheme/signature #langs to build on scheme/base
svn: r7792 original commit: 5b0a0be3d65f5a8deb871a43e077665377067aa9
This commit is contained in:
Matthew Flatt
parent
7562835461
commit
081dcf5c51
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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^)
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user