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

*** empty log message ***

Browse Source 
original commit: adb267e7ceb0e18899399bcac35a8c9150e263f4
This commit is contained in:
Adam Wick 2003-01-30 01:34:11 +00:00
parent b3b53fe9a9
commit 8ea7c826e3
10 changed files with 98 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/net/ftp-sig.ss
View File

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

23
collects/net/ftp-unit.ss
View File

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

2
collects/net/imap-sig.ss
View File

@ -7,7 +7,7 @@
(define-signature net:imap^
(imap-port-number
imap-connect
imap-connect imap-connect*
imap-disconnect
imap-force-disconnect
imap-reselect

45
collects/net/imap-unit.ss
View File

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

2
collects/net/nntp-sig.ss
View File

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

36
collects/net/nntp-unit.ss
View File

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

2
collects/net/pop3-sig.ss
View File

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

31
collects/net/pop3-unit.ss
View File

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

1
collects/net/smtp-sig.ss
View File

@ -5,5 +5,6 @@
(provide net:smtp^)
(define-signature net:smtp^
(smtp-send-message
smtp-send-message*
smtp-sending-end-of-message)))

25
collects/net/smtp-unit.ss
View File

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