diff --git a/collects/net/ftp-sig.ss b/collects/net/ftp-sig.ss index 604a075..3de7fdc 100644 --- a/collects/net/ftp-sig.ss +++ b/collects/net/ftp-sig.ss @@ -5,7 +5,7 @@ (define-signature net:ftp^ (ftp-cd - ftp-establish-connection + ftp-establish-connection ftp-establish-connection* ftp-close-connection ftp-directory-list ftp-download-file diff --git a/collects/net/ftp-unit.ss b/collects/net/ftp-unit.ss index 51458ee..0543317 100644 --- a/collects/net/ftp-unit.ss +++ b/collects/net/ftp-unit.ss @@ -131,18 +131,21 @@ ;; (printf "~a~n" s) (void)) + (define (ftp-establish-connection* in out username password) + (ftp-check-response in "220" print-msg (void)) + (fprintf out (string-append "USER " username "~n")) + (let ([no-password? (ftp-check-response in (list "331" "230") + (lambda (line 230?) + (or 230? (regexp-match "^230" line))) + #f)]) + (unless no-password? + (fprintf out (string-append "PASS " password "~n")) + (ftp-check-response in "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-check-response tcpin "220" print-msg (void)) - (fprintf tcpout (string-append "USER " username "~n")) - (let ([no-password? (ftp-check-response tcpin (list "331" "230") - (lambda (line 230?) - (or 230? (regexp-match "^230" line))) - #f)]) - (unless no-password? - (fprintf tcpout (string-append "PASS " password "~n")) - (ftp-check-response tcpin "230" void (void)))) - (make-tcp-connection tcpin tcpout))) + (ftp-establish-connection* tcpin tcpout username password))) (define (ftp-close-connection tcp-ports) (fprintf (tcp-connection-out tcp-ports) "QUIT~n") diff --git a/collects/net/imap-sig.ss b/collects/net/imap-sig.ss index 93926f8..6d28ae3 100644 --- a/collects/net/imap-sig.ss +++ b/collects/net/imap-sig.ss @@ -7,7 +7,7 @@ (define-signature net:imap^ (imap-port-number - imap-connect + imap-connect imap-connect* imap-disconnect imap-force-disconnect imap-reselect diff --git a/collects/net/imap-unit.ss b/collects/net/imap-unit.ss index 3ce3248..7c8fecf 100644 --- a/collects/net/imap-unit.ss +++ b/collects/net/imap-unit.ss @@ -176,6 +176,29 @@ (define imap-port-number (make-parameter 143)) + (define (imap-connect* r w username password inbox) + (with-handlers ([void + (lambda (x) + (close-input-port r) + (close-output-port w) + (raise x))]) + + (check-ok (imap-send r w "NOOP" void)) + (let ([reply (imap-send r w (format "LOGIN ~a ~a" + (str->arg username) + (str->arg password)) + void)]) + (if (and (pair? reply) (tag-eq? 'NO (car reply))) + (error 'imap-connect "username or password rejected by server: ~s" reply) + (check-ok reply))) + + (let ([imap (make-imap-connection r w)]) + (let-values ([(init-count init-recent) + (imap-reselect imap inbox)]) + (values imap + init-count + init-recent))))) + (define (imap-connect server username password inbox) ; => imap count-k recent-k (let-values ([(r w) (if debug-via-stdio? @@ -183,27 +206,7 @@ (printf "stdin == ~a~n" server) (values (current-input-port) (current-output-port))) (tcp-connect server (imap-port-number)))]) - (with-handlers ([void - (lambda (x) - (close-input-port r) - (close-output-port w) - (raise x))]) - - (check-ok (imap-send r w "NOOP" void)) - (let ([reply (imap-send r w (format "LOGIN ~a ~a" - (str->arg username) - (str->arg password)) - void)]) - (if (and (pair? reply) (tag-eq? 'NO (car reply))) - (error 'imap-connect "username or password rejected by server: ~s" reply) - (check-ok reply))) - - (let ([imap (make-imap-connection r w)]) - (let-values ([(init-count init-recent) - (imap-reselect imap inbox)]) - (values imap - init-count - init-recent)))))) + (imap-connect* r w username password inbox))) (define (imap-reselect imap inbox) (let ([r (imap-connection-r imap)] diff --git a/collects/net/nntp-sig.ss b/collects/net/nntp-sig.ss index 5f0ad9f..c80d4e8 100644 --- a/collects/net/nntp-sig.ss +++ b/collects/net/nntp-sig.ss @@ -6,7 +6,7 @@ (define-signature net:nntp^ ((struct communicator (sender receiver server port)) - connect-to-server disconnect-from-server + connect-to-server connect-to-server* disconnect-from-server open-news-group head-of-message body-of-message newnews-since generic-message-command diff --git a/collects/net/nntp-unit.ss b/collects/net/nntp-unit.ss index 8937fa1..9c499dc 100644 --- a/collects/net/nntp-unit.ss +++ b/collects/net/nntp-unit.ss @@ -52,6 +52,28 @@ (define default-nntpd-port-number 119) + ;; 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))) + (let-values (((code response) + (get-single-line-response communicator))) + (case code + [(201) communicator] + ((200) + communicator) + (else + ((signal-error make-unexpected-response + "unexpected connection response: ~s ~s" + code response) + code response)))))])) + ;; connect-to-server : ;; string [x number] -> commnicator @@ -59,19 +81,7 @@ (opt-lambda (server-name (port-number default-nntpd-port-number)) (let-values (((receiver sender) (tcp-connect server-name port-number))) - (let ((communicator - (make-communicator sender receiver server-name port-number))) - (let-values (((code response) - (get-single-line-response communicator))) - (case code - [(201) communicator] - ((200) - communicator) - (else - ((signal-error make-unexpected-response - "unexpected connection response: ~s ~s" - code response) - code response)))))))) + (connect-to-server* receiver sender server-name port-number)))) ;; close-communicator : ;; communicator -> () diff --git a/collects/net/pop3-sig.ss b/collects/net/pop3-sig.ss index c24d04f..3b0db30 100644 --- a/collects/net/pop3-sig.ss +++ b/collects/net/pop3-sig.ss @@ -6,7 +6,7 @@ (define-signature net:pop3^ ((struct communicator (sender receiver server port state)) - connect-to-server disconnect-from-server + connect-to-server connect-to-server* disconnect-from-server authenticate/plain-text get-mailbox-status get-message/complete get-message/headers get-message/body diff --git a/collects/net/pop3-unit.ss b/collects/net/pop3-unit.ss index ba0d611..357d408 100644 --- a/collects/net/pop3-unit.ss +++ b/collects/net/pop3-unit.ss @@ -72,23 +72,30 @@ (define-struct (+ok server-responses) ()) (define-struct (-err server-responses) ()) + ;; 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))) - (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))))))))) + (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 -> () diff --git a/collects/net/smtp-sig.ss b/collects/net/smtp-sig.ss index 46bb708..004d81d 100644 --- a/collects/net/smtp-sig.ss +++ b/collects/net/smtp-sig.ss @@ -5,5 +5,6 @@ (provide net:smtp^) (define-signature net:smtp^ (smtp-send-message + smtp-send-message* smtp-sending-end-of-message))) diff --git a/collects/net/smtp-unit.ss b/collects/net/smtp-unit.ss index 536d3fa..a3d7e1f 100644 --- a/collects/net/smtp-unit.ss +++ b/collects/net/smtp-unit.ss @@ -52,16 +52,7 @@ (raise-type-error 'smtp-sending-end-of-message "thunk" f)) f))) - (define smtp-send-message - (case-lambda - [(server sender recipients header message-lines) - (smtp-send-message server sender recipients header message-lines 25)] - [(server sender recipients header message-lines pos) - (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 pos))]) + (define (smtp-send-message* r w sender recipients header message-lines) (with-handlers ([void (lambda (x) (close-input-port r) (close-output-port w) @@ -105,4 +96,16 @@ (check-reply r 221) (close-output-port w) - (close-input-port r)))]))))) + (close-input-port r))) + + (define smtp-send-message + (case-lambda + [(server sender recipients header message-lines) + (smtp-send-message server sender recipients header message-lines 25)] + [(server sender recipients header message-lines pos) + (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 pos))]) + (smtp-send-message* r w sender recipients header message-lines))]))))) \ No newline at end of file