1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 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 (ice-9 binary-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
43 ;;; Simple FTP client (RFC 959).
47 ;; TODO: Use SRFI-3{4,5} error conditions.
49 (define-record-type <ftp-connection>
50 (%make-ftp-connection socket addrinfo)
52 (socket ftp-connection-socket)
53 (addrinfo ftp-connection-addrinfo))
56 (make-regexp "^([0-9]{3}) (.+)$"))
58 (define (%ftp-listen port)
59 (let loop ((line (read-line port)))
60 (cond ((eof-object? line) (values line #f))
61 ((regexp-exec %ftp-ready-rx line)
64 (values (string->number (match:substring match 1))
65 (match:substring match 2))))
67 (loop (read-line port))))))
69 (define (%ftp-command command expected-code port)
70 (format port "~A~A~A" command (string #\return) (string #\newline))
71 (let-values (((code message) (%ftp-listen port)))
72 (if (eqv? code expected-code)
74 (throw 'ftp-error port command code message))))
76 (define (%ftp-login user pass port)
77 (let ((command (string-append "USER " user
78 (string #\return) (string #\newline))))
79 (display command port)
80 (let-values (((code message) (%ftp-listen port)))
83 ((331) (%ftp-command (string-append "PASS " pass) 230 port))
84 (else (throw 'ftp-error port command code message))))))
86 (define-syntax-rule (catch-EINPROGRESS body ...)
91 (unless (= (system-error-errno args) EINPROGRESS)
92 (apply throw args)))))
94 ;; XXX: For lack of a better place.
95 (define* (connect* s sockaddr #:optional timeout)
96 "When TIMEOUT is omitted or #f, this procedure is equivalent to 'connect'.
97 When TIMEOUT is a number, it is the (possibly inexact) maximum number of
98 seconds to wait for the connection to succeed."
99 (define (raise-error errno)
100 (throw 'system-error 'connect* "~A"
101 (list (strerror errno))
105 (let ((flags (fcntl s F_GETFL)))
106 (fcntl s F_SETFL (logior flags O_NONBLOCK))
107 (catch-EINPROGRESS (connect s sockaddr))
108 (match (select '() (list s) (list s) timeout)
111 (raise-error ETIMEDOUT))
113 ;; Check for ECONNREFUSED and the likes.
114 (fcntl s F_SETFL flags)
115 (let ((errno (getsockopt s SOL_SOCKET SO_ERROR)))
116 (unless (zero? errno)
117 (raise-error errno))))
119 ;; Seems like this cannot really happen, but who knows.
120 (let ((errno (getsockopt s SOL_SOCKET SO_ERROR)))
121 (raise-error errno)))))
122 (connect s sockaddr)))
124 (define* (ftp-open host #:optional (port "ftp")
126 (username "anonymous")
127 (password "guix@example.com"))
128 "Open an FTP connection to HOST on PORT (a service-identifying string,
129 or a TCP port number), and return it.
131 When TIMEOUT is not #f, it must be a (possibly inexact) number denoting the
132 maximum duration in seconds to wait for the connection to complete; passed
133 TIMEOUT, an ETIMEDOUT error is raised."
134 ;; Using "ftp" for PORT instead of 21 allows 'getaddrinfo' to return only
135 ;; TCP/IP addresses (otherwise it would return SOCK_DGRAM and SOCK_RAW
136 ;; addresses as well.) With our bootstrap Guile, which includes a
137 ;; statically-linked NSS, resolving "ftp" works well, as long as
138 ;; /etc/services is available.
142 (if (number? port) (number->string port) port)
144 (logior AI_ADDRCONFIG AI_NUMERICSERV)
147 (let loop ((addresses addresses))
150 (let ((s (socket (addrinfo:fam ai)
152 SOCK_STREAM IPPROTO_IP)))
156 (connect* s (addrinfo:addr ai) timeout)
158 (let-values (((code message) (%ftp-listen s)))
161 ;;(%ftp-command "OPTS UTF8 ON" 200 s)
162 (%ftp-login username password s)
163 (%make-ftp-connection s ai))
166 (throw 'ftp-error s "log-in" code message)))))
169 ;; Connection failed, so try one of the other addresses.
175 (define (ftp-close conn)
176 (close (ftp-connection-socket conn)))
178 (define %char-set:not-slash
179 (char-set-complement (char-set #\/)))
181 (define (ftp-chdir conn dir)
182 "Change to directory DIR."
184 ;; On ftp.gnupg.org, "PASV" right after "CWD /gcrypt/gnupg" hangs. Doing
185 ;; CWD in two steps works, so just do this.
186 (let ((components (string-tokenize dir %char-set:not-slash)))
187 (fold (lambda (dir result)
188 (%ftp-command (string-append "CWD " dir) 250
189 (ftp-connection-socket conn)))
191 (if (string-prefix? "/" dir)
192 (cons "/" components)
195 (define (ftp-size conn file)
196 "Return the size in bytes of FILE."
198 ;; Ask for "binary mode", otherwise some servers, such as sourceware.org,
199 ;; fail with 550 ("SIZE not allowed in ASCII mode").
200 (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))
202 (let ((message (%ftp-command (string-append "SIZE " file) 213
203 (ftp-connection-socket conn))))
204 (string->number (string-trim-both message))))
206 (define (ftp-pasv conn)
208 (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))
210 (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
211 (cond ((regexp-exec %pasv-rx message)
214 (+ (* (string->number (match:substring match 5)) 256)
215 (string->number (match:substring match 6)))))
217 (throw 'ftp-error conn "PASV" 227 message)))))
219 (define (address-with-port sa port)
220 "Return a socket-address object based on SA, but with PORT."
221 (let ((fam (sockaddr:fam sa))
222 (addr (sockaddr:addr sa)))
223 (cond ((= fam AF_INET)
224 (make-socket-address fam addr port))
226 (make-socket-address fam addr port
227 (sockaddr:flowinfo sa)
228 (sockaddr:scopeid sa)))
231 (define* (ftp-list conn #:optional directory #:key timeout)
233 (ftp-chdir conn directory))
235 (let* ((port (ftp-pasv conn))
236 (ai (ftp-connection-addrinfo conn))
237 (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
238 (addrinfo:protocol ai))))
239 (connect* s (address-with-port (addrinfo:addr ai) port) timeout)
245 (%ftp-command "LIST" 150 (ftp-connection-socket conn))
247 (let loop ((line (read-line s))
249 (cond ((eof-object? line) (reverse result))
250 ((regexp-exec %ftp-ready-rx line)
253 (let ((code (string->number (match:substring match 1))))
256 (throw 'ftp-error conn "LIST" code)))))
259 (match (reverse (string-tokenize line))
260 ((file _ ... permissions)
261 (let ((type (case (string-ref permissions 0)
264 (cons (list file type) result)))
266 (cons (cons file 'file) result))))))))
269 (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
271 (throw 'ftp-error conn "LIST" code message)))))))
273 (define* (ftp-retr conn file #:optional directory
275 "Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from
276 FTP connection CONN. Return a binary port to that file. The returned port
277 must be closed before CONN can be used for other purposes."
279 (ftp-chdir conn directory))
281 ;; Ask for "binary mode".
282 (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))
284 (let* ((port (ftp-pasv conn))
285 (ai (ftp-connection-addrinfo conn))
286 (s (with-fluids ((%default-port-encoding #f))
287 (socket (addrinfo:fam ai) (addrinfo:socktype ai)
288 (addrinfo:protocol ai)))))
291 (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
293 (throw 'ftp-error conn "LIST" code message))))
295 (connect* s (address-with-port (addrinfo:addr ai) port) timeout)
298 (%ftp-command (string-append "RETR " file)
299 150 (ftp-connection-socket conn))
301 (make-custom-binary-input-port "FTP RETR port"
302 (rec (read! bv start count)
303 (match (get-bytevector-n! s bv
307 ;; Nothing available yet, so try
308 ;; again. This is important because
309 ;; the return value of `read!' makes
310 ;; it impossible to distinguish
311 ;; between "not yet" and "EOF".
312 (read! bv start count))
314 #f #f ; no get/set position
317 ;;; ftp-client.scm ends here