Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
2a31e1da | 2 | ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
457dd86d | 3 | ;;; |
233e7676 | 4 | ;;; This file is part of GNU Guix. |
457dd86d | 5 | ;;; |
233e7676 | 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
457dd86d LC |
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. | |
10 | ;;; | |
233e7676 | 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
457dd86d LC |
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. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
233e7676 | 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
457dd86d LC |
18 | |
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 | |
32 | ||
48567006 | 33 | connect* |
457dd86d LC |
34 | ftp-open |
35 | ftp-close | |
36 | ftp-chdir | |
fb83842e | 37 | ftp-size |
457dd86d LC |
38 | ftp-list |
39 | ftp-retr)) | |
40 | ||
41 | ;;; Commentary: | |
42 | ;;; | |
43 | ;;; Simple FTP client (RFC 959). | |
44 | ;;; | |
45 | ;;; Code: | |
46 | ||
47 | ;; TODO: Use SRFI-3{4,5} error conditions. | |
48 | ||
49 | (define-record-type <ftp-connection> | |
50 | (%make-ftp-connection socket addrinfo) | |
51 | ftp-connection? | |
52 | (socket ftp-connection-socket) | |
53 | (addrinfo ftp-connection-addrinfo)) | |
54 | ||
55 | (define %ftp-ready-rx | |
56 | (make-regexp "^([0-9]{3}) (.+)$")) | |
57 | ||
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) | |
62 | => | |
63 | (lambda (match) | |
64 | (values (string->number (match:substring match 1)) | |
65 | (match:substring match 2)))) | |
66 | (else | |
67 | (loop (read-line port)))))) | |
68 | ||
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) | |
73 | message | |
74 | (throw 'ftp-error port command code message)))) | |
75 | ||
76 | (define (%ftp-login user pass port) | |
3c986b75 LC |
77 | (let ((command (string-append "USER " user |
78 | (string #\return) (string #\newline)))) | |
457dd86d LC |
79 | (display command port) |
80 | (let-values (((code message) (%ftp-listen port))) | |
81 | (case code | |
82 | ((230) #t) | |
83 | ((331) (%ftp-command (string-append "PASS " pass) 230 port)) | |
84 | (else (throw 'ftp-error port command code message)))))) | |
85 | ||
48567006 LC |
86 | (define-syntax-rule (catch-EINPROGRESS body ...) |
87 | (catch 'system-error | |
88 | (lambda () | |
89 | body ...) | |
90 | (lambda args | |
91 | (unless (= (system-error-errno args) EINPROGRESS) | |
92 | (apply throw args))))) | |
93 | ||
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)) | |
102 | (list errno))) | |
103 | ||
104 | (if timeout | |
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) | |
109 | ((() () ()) | |
110 | ;; Time is up! | |
111 | (raise-error ETIMEDOUT)) | |
112 | ((() (write) ()) | |
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)))) | |
118 | ((() () (except)) | |
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))) | |
123 | ||
124 | (define* (ftp-open host #:optional (port 21) #:key timeout) | |
d14ecda9 | 125 | "Open an FTP connection to HOST on PORT (a service-identifying string, |
48567006 LC |
126 | or a TCP port number), and return it. |
127 | ||
128 | When TIMEOUT is not #f, it must be a (possibly inexact) number denoting the | |
129 | maximum duration in seconds to wait for the connection to complete; passed | |
130 | TIMEOUT, an ETIMEDOUT error is raised." | |
d14ecda9 LC |
131 | ;; Use 21 as the default PORT instead of "ftp", to avoid depending on |
132 | ;; libc's NSS, which is not available during bootstrap. | |
133 | ||
91fe0e20 LC |
134 | (define addresses |
135 | (getaddrinfo host | |
136 | (if (number? port) (number->string port) port) | |
1b9aefa3 LC |
137 | (if (number? port) |
138 | (logior AI_ADDRCONFIG AI_NUMERICSERV) | |
139 | AI_ADDRCONFIG))) | |
91fe0e20 LC |
140 | |
141 | (let loop ((addresses addresses)) | |
d6d33984 LC |
142 | (match addresses |
143 | ((ai rest ...) | |
144 | (let ((s (socket (addrinfo:fam ai) | |
145 | ;; TCP/IP only | |
146 | SOCK_STREAM IPPROTO_IP))) | |
147 | ||
148 | (catch 'system-error | |
149 | (lambda () | |
150 | (connect* s (addrinfo:addr ai) timeout) | |
151 | (setvbuf s _IOLBF) | |
152 | (let-values (((code message) (%ftp-listen s))) | |
153 | (if (eqv? code 220) | |
154 | (begin | |
155 | ;;(%ftp-command "OPTS UTF8 ON" 200 s) | |
156 | (%ftp-login "anonymous" "guix@example.com" s) | |
157 | (%make-ftp-connection s ai)) | |
158 | (begin | |
159 | (close s) | |
160 | (throw 'ftp-error s "log-in" code message))))) | |
161 | ||
162 | (lambda args | |
163 | ;; Connection failed, so try one of the other addresses. | |
164 | (close s) | |
165 | (if (null? rest) | |
166 | (apply throw args) | |
167 | (loop rest))))))))) | |
457dd86d LC |
168 | |
169 | (define (ftp-close conn) | |
170 | (close (ftp-connection-socket conn))) | |
171 | ||
87dfd455 LC |
172 | (define %char-set:not-slash |
173 | (char-set-complement (char-set #\/))) | |
174 | ||
457dd86d | 175 | (define (ftp-chdir conn dir) |
87dfd455 LC |
176 | "Change to directory DIR." |
177 | ||
178 | ;; On ftp.gnupg.org, "PASV" right after "CWD /gcrypt/gnupg" hangs. Doing | |
179 | ;; CWD in two steps works, so just do this. | |
180 | (let ((components (string-tokenize dir %char-set:not-slash))) | |
181 | (fold (lambda (dir result) | |
182 | (%ftp-command (string-append "CWD " dir) 250 | |
183 | (ftp-connection-socket conn))) | |
184 | #f | |
185 | (if (string-prefix? "/" dir) | |
186 | (cons "/" components) | |
187 | components)))) | |
457dd86d | 188 | |
fb83842e LC |
189 | (define (ftp-size conn file) |
190 | "Return the size in bytes of FILE." | |
2a31e1da LC |
191 | |
192 | ;; Ask for "binary mode", otherwise some servers, such as sourceware.org, | |
193 | ;; fail with 550 ("SIZE not allowed in ASCII mode"). | |
194 | (%ftp-command "TYPE I" 200 (ftp-connection-socket conn)) | |
195 | ||
fb83842e LC |
196 | (let ((message (%ftp-command (string-append "SIZE " file) 213 |
197 | (ftp-connection-socket conn)))) | |
198 | (string->number (string-trim-both message)))) | |
199 | ||
457dd86d LC |
200 | (define (ftp-pasv conn) |
201 | (define %pasv-rx | |
202 | (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)")) | |
203 | ||
204 | (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn)))) | |
205 | (cond ((regexp-exec %pasv-rx message) | |
206 | => | |
207 | (lambda (match) | |
208 | (+ (* (string->number (match:substring match 5)) 256) | |
209 | (string->number (match:substring match 6))))) | |
210 | (else | |
211 | (throw 'ftp-error conn "PASV" 227 message))))) | |
212 | ||
213 | (define (address-with-port sa port) | |
214 | "Return a socket-address object based on SA, but with PORT." | |
215 | (let ((fam (sockaddr:fam sa)) | |
216 | (addr (sockaddr:addr sa))) | |
217 | (cond ((= fam AF_INET) | |
218 | (make-socket-address fam addr port)) | |
219 | ((= fam AF_INET6) | |
220 | (make-socket-address fam addr port | |
221 | (sockaddr:flowinfo sa) | |
222 | (sockaddr:scopeid sa))) | |
223 | (else #f)))) | |
224 | ||
225 | (define* (ftp-list conn #:optional directory) | |
226 | (if directory | |
227 | (ftp-chdir conn directory)) | |
228 | ||
229 | (let* ((port (ftp-pasv conn)) | |
230 | (ai (ftp-connection-addrinfo conn)) | |
231 | (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) | |
232 | (addrinfo:protocol ai)))) | |
233 | (connect s (address-with-port (addrinfo:addr ai) port)) | |
234 | (setvbuf s _IOLBF) | |
235 | ||
236 | (dynamic-wind | |
237 | (lambda () #t) | |
238 | (lambda () | |
239 | (%ftp-command "LIST" 150 (ftp-connection-socket conn)) | |
240 | ||
241 | (let loop ((line (read-line s)) | |
242 | (result '())) | |
243 | (cond ((eof-object? line) (reverse result)) | |
244 | ((regexp-exec %ftp-ready-rx line) | |
245 | => | |
246 | (lambda (match) | |
247 | (let ((code (string->number (match:substring match 1)))) | |
248 | (if (= 126 code) | |
249 | (reverse result) | |
250 | (throw 'ftp-error conn "LIST" code))))) | |
251 | (else | |
252 | (loop (read-line s) | |
253 | (match (reverse (string-tokenize line)) | |
254 | ((file _ ... permissions) | |
255 | (let ((type (case (string-ref permissions 0) | |
256 | ((#\d) 'directory) | |
257 | (else 'file)))) | |
258 | (cons (list file type) result))) | |
259 | ((file _ ...) | |
260 | (cons (cons file 'file) result)))))))) | |
261 | (lambda () | |
262 | (close s) | |
263 | (let-values (((code message) (%ftp-listen (ftp-connection-socket conn)))) | |
264 | (or (eqv? code 226) | |
265 | (throw 'ftp-error conn "LIST" code message))))))) | |
266 | ||
267 | (define* (ftp-retr conn file #:optional directory) | |
268 | "Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from | |
269 | FTP connection CONN. Return a binary port to that file. The returned port | |
270 | must be closed before CONN can be used for other purposes." | |
271 | (if directory | |
272 | (ftp-chdir conn directory)) | |
273 | ||
274 | ;; Ask for "binary mode". | |
275 | (%ftp-command "TYPE I" 200 (ftp-connection-socket conn)) | |
276 | ||
277 | (let* ((port (ftp-pasv conn)) | |
278 | (ai (ftp-connection-addrinfo conn)) | |
279 | (s (with-fluids ((%default-port-encoding #f)) | |
280 | (socket (addrinfo:fam ai) (addrinfo:socktype ai) | |
281 | (addrinfo:protocol ai))))) | |
282 | (define (terminate) | |
283 | (close s) | |
284 | (let-values (((code message) (%ftp-listen (ftp-connection-socket conn)))) | |
285 | (or (eqv? code 226) | |
286 | (throw 'ftp-error conn "LIST" code message)))) | |
287 | ||
288 | (connect s (address-with-port (addrinfo:addr ai) port)) | |
289 | (setvbuf s _IOLBF) | |
290 | ||
291 | (%ftp-command (string-append "RETR " file) | |
292 | 150 (ftp-connection-socket conn)) | |
293 | ||
294 | (make-custom-binary-input-port "FTP RETR port" | |
295 | (rec (read! bv start count) | |
296 | (match (get-bytevector-n! s bv | |
297 | start count) | |
87dfd455 LC |
298 | ((? eof-object?) 0) |
299 | (0 | |
300 | ;; Nothing available yet, so try | |
301 | ;; again. This is important because | |
302 | ;; the return value of `read!' makes | |
303 | ;; it impossible to distinguish | |
304 | ;; between "not yet" and "EOF". | |
305 | (read! bv start count)) | |
306 | (read read))) | |
457dd86d LC |
307 | #f #f ; no get/set position |
308 | terminate))) | |
309 | ||
310 | ;;; ftp-client.scm ends here |