scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Rewrite reply code testing with predicates instead of regexps.

This commit is contained in:
sperber 2003-01-16 09:40:34 +00:00
parent 045ded0d30
commit 1a0099230c
2 changed files with 52 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
scheme/lib/ftp.scm
View File

@ -108,7 +108,7 @@
(format #f "~%-- ~a: opened ftp connection to ~a"
(date->string (date))
hostname))
(ftp-read-reply connection "220") ; the initial welcome banner
(ftp-read-reply connection (exactly-code "220")) ; the initial welcome banner
connection)))
;; Send user information to the remote host. Args are optional login
@ -127,8 +127,8 @@
(ftp-connection-host-name connection))))
(set-ftp-connection-login! connection login)
(set-ftp-connection-password! connection password)
(ftp-send-command connection (format #f "USER ~a" login) "...") ; "331"
(ftp-send-command connection (format #f "PASS ~a" password) "2..")))) ; "230"
(ftp-send-command connection (format #f "USER ~a" login) any-code) ; "331"
(ftp-send-command connection (format #f "PASS ~a" password))))) ; "230"
;; Type must be one of 'binary or 'text or 'ascii, or a string which will be
;; sent verbatim
@ -146,12 +146,12 @@
;;: connection x string x string -> status
(define (ftp-rename connection oldname newname)
(ftp-send-command connection (format #f "RNFR ~a" oldname) "35.")
(ftp-send-command connection (format #f "RNTO ~a" newname) "25."))
(ftp-send-command connection (format #f "RNFR ~a" oldname) (code-with-prefix "35"))
(ftp-send-command connection (format #f "RNTO ~a" newname) (code-with-prefix "25")))
;;: connection x string -> status
(define (ftp-delete connection file)
(ftp-send-command connection (format #f "DELE ~a" file) "25."))
(ftp-send-command connection (format #f "DELE ~a" file) (code-with-prefix "25")))
;;: connection x string -> status
(define (ftp-cd connection dir)
@ -159,12 +159,12 @@
;;: connection -> status
(define (ftp-cdup connection)
(ftp-send-command connection "CDUP" "250"))
(ftp-send-command connection "CDUP" (exactly-code "250")))
;;: on success return the new directory as a string
(define (ftp-pwd connection)
(let* ((reply (ftp-send-command connection "PWD" "2..")) ; 257
(let* ((reply (ftp-send-command connection "PWD")) ; 257
(match (string-match "[0-9][0-9][0-9] \"(.*)\" " (or reply ""))))
(match:substring match 1)))
@ -203,8 +203,7 @@
;;: connection x string -> integer
(define (ftp-size connection file)
(let* ((reply (ftp-send-command connection
(format #f "SIZE ~a" file)
"2..")))
(format #f "SIZE ~a" file))))
(and (string? reply)
(string->number (substring reply
4 (- (string-length reply) 1))))))
@ -217,7 +216,7 @@
;;: connection -> status
(define (ftp-quit connection)
(ftp-send-command connection "QUIT" "221")
(ftp-send-command connection "QUIT" (exactly-code "221"))
(close-socket (ftp-connection-command-socket connection)))
@ -242,26 +241,26 @@
(let* ((sock (ftp-open-data-connection connection)))
(ftp-send-command connection
(ftp-build-command-string "NLST" maybe-dir)
"1..")
(code-with-prefix "1"))
(receive (newsock newsockaddr)
(accept-connection sock)
(dump (socket:inport newsock))
(close-socket newsock)
(close-socket sock)
(ftp-read-reply connection "2.."))))
(ftp-read-reply connection))))
;;: connection [ x string ] -> status
(define (ftp-dir connection . maybe-dir)
(let* ((sock (ftp-open-data-connection connection)))
(ftp-send-command connection
(ftp-build-command-string "LIST" maybe-dir)
"1..")
(code-with-prefix "1"))
(receive (newsock newsockaddr)
(accept-connection sock)
(dump (socket:inport newsock))
(close-socket newsock)
(close-socket sock)
(ftp-read-reply connection "2.."))))
(ftp-read-reply connection))))
;; maybe-local may be a filename to which the data should be written,
@ -282,14 +281,14 @@
(open-output-file remote-file)))))
(ftp-send-command connection
(format #f "RETR ~a" remote-file)
"150")
(exactly-code "150"))
(receive (newsock newsockaddr)
(accept-connection sock)
(with-current-output-port OUT
(dump (socket:inport newsock)))
(close-socket newsock)
(close-socket sock)
(let ((status (ftp-read-reply connection "2..")))
(let ((status (ftp-read-reply connection)))
(if (string? local) (close OUT))
(if (eq? local #f)
(string-output-port-output OUT)
@ -311,13 +310,13 @@
(let* ((sock (ftp-open-data-connection connection))
(IN (open-input-file local-file))
(cmd (format #f "STOR ~a" (or remote-file local-file))))
(ftp-send-command connection cmd "150")
(ftp-send-command connection cmd (exactly-code "150"))
(receive (newsock newsockaddr)
(accept-connection sock)
(with-current-output-port (socket:outport newsock) (dump IN))
(close (socket:outport newsock)) ; send the server EOF
(close-socket newsock)
(let ((status (ftp-read-reply connection "2..")))
(let ((status (ftp-read-reply connection)))
(close IN)
(close-socket sock)
status)))))
@ -328,14 +327,14 @@
(let* ((sock (ftp-open-data-connection connection))
(IN (open-input-file local-file))
(cmd (format #f "APPE ~a" (or remote-file local-file))))
(ftp-send-command connection cmd "150")
(ftp-send-command connection cmd (exactly-code "150"))
(receive (newsock newsockaddr)
(accept-connection sock)
(with-current-output-port (socket:outport newsock)
(dump IN))
(close (socket:outport newsock)) ; send the server EOF
(close-socket newsock)
(let ((status (ftp-read-reply connection "2..")))
(let ((status (ftp-read-reply connection)))
(close IN)
(close-socket sock)
status)))))
@ -400,44 +399,46 @@
(format-port srvc-port)))))
(define (ftp-send-command connection command . maybe-expected)
(let-optionals* maybe-expected ((expected "2.."))
(let* ((sock (ftp-connection-command-socket connection))
(OUT (socket:outport sock)))
(write-string command OUT)
(write-crlf OUT)
(ftp-log connection (format #f "<- ~a" command))
(ftp-read-reply connection expected))))
(let* ((sock (ftp-connection-command-socket connection))
(OUT (socket:outport sock)))
(write-string command OUT)
(write-crlf OUT)
(ftp-log connection (format #f "<- ~a" command))
(apply ftp-read-reply connection maybe-expected)))
(define any-code (lambda (code) #t))
(define (code-with-prefix prefix)
(lambda (code)
(string-prefix? prefix code)))
(define (exactly-code the-code)
(lambda (code)
(string=? code the-code)))
;; This is where we check that the server's 3 digit status code
;; corresponds to what we expected. EXPECTED is a string of the form
;; "250", which indicates we are expecting a 250 code from the server,
;; or "2.." which means that we only require the first digit to be 2
;; and don't care about the rest. If the server's reply doesn't
;; match EXPECTED, we raise an ftp-error (which is catchable; look at
;; pop3.scm to see how). Since this is implemented as a regexp, you
;; can also specify more complicated acceptable replies of the form
;; "2[4-6][0-9]". The code permits you to match the server's verbose
;; message too, but beware that the messages change from server to
;; server.
;; corresponds to what we expected.
;; EXPECTED? is a predicate on reply codes. If the server's reply
;; doesn't satisfy EXPECTED?, we raise an FTP-ERROR.
(define (ftp-read-reply connection . maybe-expected)
(let-optionals* maybe-expected ((expected "2.."))
(let-optionals* maybe-expected ((expected? (code-with-prefix "2")))
(let* ((sock (ftp-connection-command-socket connection))
(IN (socket:inport sock))
(reply (read-crlf-line IN)))
(reply (read-crlf-line IN))
(code (substring reply 0 3)))
(ftp-log connection (format #f "-> ~a" reply))
(or (string-match expected reply)
(if (not (expected? code))
(signal 'ftp-error reply))
;; handle multi-line replies
(if (equal? (string-ref reply 3) #\-)
(let loop ((code (string-append (substring reply 0 3) " "))
(line (read-crlf-line IN)))
(ftp-log connection (format #f "-> ~a" line))
(set! reply (string-join (list reply line "\n")))
(or (string-match code line)
(loop code (read-crlf-line IN)))))
reply)))
(if (char=? (string-ref reply 3) #\-)
(let loop ()
(let* ((line (read-crlf-line IN))
(reply (string-join (list reply line "\n"))))
(ftp-log connection (format #f "-> ~a" line))
(if (string-prefix? code line)
reply
(loop code reply))))
reply))))
(define (ftp-build-command-string str . opt-args)
(if (string? opt-args)

2
scheme/packages.scm
View File

@ -409,7 +409,7 @@
handle
conditions
signals
(subset srfi-13 (string-join))
(subset srfi-13 (string-join string-prefix?))
let-opt
sunet-utilities
format-net