diff --git a/scheme/lib/ftp.scm b/scheme/lib/ftp.scm index b2775d7..c05c8d7 100644 --- a/scheme/lib/ftp.scm +++ b/scheme/lib/ftp.scm @@ -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) diff --git a/scheme/packages.scm b/scheme/packages.scm index 11a90af..091477d 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -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