1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (guix ftp-client)
20 #:use-module (srfi srfi-1)
21 #:use-module (srfi srfi-9)
22 #:use-module (srfi srfi-11)
23 #:use-module (srfi srfi-26)
24 #:use-module (srfi srfi-31)
25 #:use-module (rnrs io ports)
26 #:use-module (rnrs bytevectors)
27 #:use-module (ice-9 match)
28 #:use-module (ice-9 regex)
29 #:use-module (ice-9 rdelim)
30 #:export (ftp-connection?
31 ftp-connection-addrinfo
42 ;;; Simple FTP client (RFC 959).
46 ;; TODO: Use SRFI-3{4,5} error conditions.
48 (define-record-type <ftp-connection>
49 (%make-ftp-connection socket addrinfo)
51 (socket ftp-connection-socket)
52 (addrinfo ftp-connection-addrinfo))
55 (make-regexp "^([0-9]{3}) (.+)$"))
57 (define (%ftp-listen port)
58 (let loop ((line (read-line port)))
59 (cond ((eof-object? line) (values line #f))
60 ((regexp-exec %ftp-ready-rx line)
63 (values (string->number (match:substring match 1))
64 (match:substring match 2))))
66 (loop (read-line port))))))
68 (define (%ftp-command command expected-code port)
69 (format port "~A~A~A" command (string #\return) (string #\newline))
70 (let-values (((code message) (%ftp-listen port)))
71 (if (eqv? code expected-code)
73 (throw 'ftp-error port command code message))))
75 (define (%ftp-login user pass port)
76 (let ((command (string-append "USER " user (string #\newline))))
77 (display command port)
78 (let-values (((code message) (%ftp-listen port)))
81 ((331) (%ftp-command (string-append "PASS " pass) 230 port))
82 (else (throw 'ftp-error port command code message))))))
84 (define* (ftp-open host #:optional (port 21))
85 "Open an FTP connection to HOST on PORT (a service-identifying string,
86 or a TCP port number), and return it."
87 ;; Use 21 as the default PORT instead of "ftp", to avoid depending on
88 ;; libc's NSS, which is not available during bootstrap.
92 (if (number? port) (number->string port) port)
93 (if (number? port) AI_NUMERICSERV 0)))
95 (let loop ((addresses addresses))
96 (let* ((ai (car addresses))
97 (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
98 (addrinfo:protocol ai))))
102 (connect s (addrinfo:addr ai))
104 (let-values (((code message) (%ftp-listen s)))
107 ;;(%ftp-command "OPTS UTF8 ON" 200 s)
108 (%ftp-login "anonymous" "guix@example.com" s)
109 (%make-ftp-connection s ai))
111 (format (current-error-port)
112 "FTP to `~a' failed: ~A: ~A~%"
118 ;; Connection failed, so try one of the other addresses.
120 (if (null? addresses)
122 (loop (cdr addresses))))))))
124 (define (ftp-close conn)
125 (close (ftp-connection-socket conn)))
127 (define %char-set:not-slash
128 (char-set-complement (char-set #\/)))
130 (define (ftp-chdir conn dir)
131 "Change to directory DIR."
133 ;; On ftp.gnupg.org, "PASV" right after "CWD /gcrypt/gnupg" hangs. Doing
134 ;; CWD in two steps works, so just do this.
135 (let ((components (string-tokenize dir %char-set:not-slash)))
136 (fold (lambda (dir result)
137 (%ftp-command (string-append "CWD " dir) 250
138 (ftp-connection-socket conn)))
140 (if (string-prefix? "/" dir)
141 (cons "/" components)
144 (define (ftp-size conn file)
145 "Return the size in bytes of FILE."
146 (let ((message (%ftp-command (string-append "SIZE " file) 213
147 (ftp-connection-socket conn))))
148 (string->number (string-trim-both message))))
150 (define (ftp-pasv conn)
152 (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))
154 (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
155 (cond ((regexp-exec %pasv-rx message)
158 (+ (* (string->number (match:substring match 5)) 256)
159 (string->number (match:substring match 6)))))
161 (throw 'ftp-error conn "PASV" 227 message)))))
163 (define (address-with-port sa port)
164 "Return a socket-address object based on SA, but with PORT."
165 (let ((fam (sockaddr:fam sa))
166 (addr (sockaddr:addr sa)))
167 (cond ((= fam AF_INET)
168 (make-socket-address fam addr port))
170 (make-socket-address fam addr port
171 (sockaddr:flowinfo sa)
172 (sockaddr:scopeid sa)))
175 (define* (ftp-list conn #:optional directory)
177 (ftp-chdir conn directory))
179 (let* ((port (ftp-pasv conn))
180 (ai (ftp-connection-addrinfo conn))
181 (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
182 (addrinfo:protocol ai))))
183 (connect s (address-with-port (addrinfo:addr ai) port))
189 (%ftp-command "LIST" 150 (ftp-connection-socket conn))
191 (let loop ((line (read-line s))
193 (cond ((eof-object? line) (reverse result))
194 ((regexp-exec %ftp-ready-rx line)
197 (let ((code (string->number (match:substring match 1))))
200 (throw 'ftp-error conn "LIST" code)))))
203 (match (reverse (string-tokenize line))
204 ((file _ ... permissions)
205 (let ((type (case (string-ref permissions 0)
208 (cons (list file type) result)))
210 (cons (cons file 'file) result))))))))
213 (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
215 (throw 'ftp-error conn "LIST" code message)))))))
217 (define* (ftp-retr conn file #:optional directory)
218 "Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from
219 FTP connection CONN. Return a binary port to that file. The returned port
220 must be closed before CONN can be used for other purposes."
222 (ftp-chdir conn directory))
224 ;; Ask for "binary mode".
225 (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))
227 (let* ((port (ftp-pasv conn))
228 (ai (ftp-connection-addrinfo conn))
229 (s (with-fluids ((%default-port-encoding #f))
230 (socket (addrinfo:fam ai) (addrinfo:socktype ai)
231 (addrinfo:protocol ai)))))
234 (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
236 (throw 'ftp-error conn "LIST" code message))))
238 (connect s (address-with-port (addrinfo:addr ai) port))
241 (%ftp-command (string-append "RETR " file)
242 150 (ftp-connection-socket conn))
244 (make-custom-binary-input-port "FTP RETR port"
245 (rec (read! bv start count)
246 (match (get-bytevector-n! s bv
250 ;; Nothing available yet, so try
251 ;; again. This is important because
252 ;; the return value of `read!' makes
253 ;; it impossible to distinguish
254 ;; between "not yet" and "EOF".
255 (read! bv start count))
257 #f #f ; no get/set position
260 ;;; ftp-client.scm ends here