Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
76832d34 | 2 | ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019 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) | |
2535635f | 25 | #:use-module (ice-9 binary-ports) |
457dd86d LC |
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 | ||
193420a8 RJ |
124 | (define* (ftp-open host #:optional (port "ftp") |
125 | #:key timeout | |
126 | (username "anonymous") | |
127 | (password "guix@example.com")) | |
d14ecda9 | 128 | "Open an FTP connection to HOST on PORT (a service-identifying string, |
48567006 LC |
129 | or a TCP port number), and return it. |
130 | ||
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." | |
862d2479 LC |
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. | |
d14ecda9 | 139 | |
91fe0e20 LC |
140 | (define addresses |
141 | (getaddrinfo host | |
142 | (if (number? port) (number->string port) port) | |
1b9aefa3 LC |
143 | (if (number? port) |
144 | (logior AI_ADDRCONFIG AI_NUMERICSERV) | |
145 | AI_ADDRCONFIG))) | |
91fe0e20 LC |
146 | |
147 | (let loop ((addresses addresses)) | |
d6d33984 LC |
148 | (match addresses |
149 | ((ai rest ...) | |
150 | (let ((s (socket (addrinfo:fam ai) | |
151 | ;; TCP/IP only | |
152 | SOCK_STREAM IPPROTO_IP))) | |
153 | ||
154 | (catch 'system-error | |
155 | (lambda () | |
156 | (connect* s (addrinfo:addr ai) timeout) | |
76832d34 | 157 | (setvbuf s 'line) |
d6d33984 LC |
158 | (let-values (((code message) (%ftp-listen s))) |
159 | (if (eqv? code 220) | |
160 | (begin | |
161 | ;;(%ftp-command "OPTS UTF8 ON" 200 s) | |
193420a8 | 162 | (%ftp-login username password s) |
d6d33984 LC |
163 | (%make-ftp-connection s ai)) |
164 | (begin | |
165 | (close s) | |
166 | (throw 'ftp-error s "log-in" code message))))) | |
167 | ||
168 | (lambda args | |
169 | ;; Connection failed, so try one of the other addresses. | |
170 | (close s) | |
171 | (if (null? rest) | |
172 | (apply throw args) | |
173 | (loop rest))))))))) | |
457dd86d LC |
174 | |
175 | (define (ftp-close conn) | |
176 | (close (ftp-connection-socket conn))) | |
177 | ||
87dfd455 LC |
178 | (define %char-set:not-slash |
179 | (char-set-complement (char-set #\/))) | |
180 | ||
457dd86d | 181 | (define (ftp-chdir conn dir) |
87dfd455 LC |
182 | "Change to directory DIR." |
183 | ||
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))) | |
190 | #f | |
191 | (if (string-prefix? "/" dir) | |
192 | (cons "/" components) | |
193 | components)))) | |
457dd86d | 194 | |
fb83842e LC |
195 | (define (ftp-size conn file) |
196 | "Return the size in bytes of FILE." | |
2a31e1da LC |
197 | |
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)) | |
201 | ||
fb83842e LC |
202 | (let ((message (%ftp-command (string-append "SIZE " file) 213 |
203 | (ftp-connection-socket conn)))) | |
204 | (string->number (string-trim-both message)))) | |
205 | ||
457dd86d LC |
206 | (define (ftp-pasv conn) |
207 | (define %pasv-rx | |
208 | (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)")) | |
209 | ||
210 | (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn)))) | |
211 | (cond ((regexp-exec %pasv-rx message) | |
212 | => | |
213 | (lambda (match) | |
214 | (+ (* (string->number (match:substring match 5)) 256) | |
215 | (string->number (match:substring match 6))))) | |
216 | (else | |
217 | (throw 'ftp-error conn "PASV" 227 message))))) | |
218 | ||
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)) | |
225 | ((= fam AF_INET6) | |
226 | (make-socket-address fam addr port | |
227 | (sockaddr:flowinfo sa) | |
228 | (sockaddr:scopeid sa))) | |
229 | (else #f)))) | |
230 | ||
9f860595 | 231 | (define* (ftp-list conn #:optional directory #:key timeout) |
457dd86d LC |
232 | (if directory |
233 | (ftp-chdir conn directory)) | |
234 | ||
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)))) | |
9f860595 | 239 | (connect* s (address-with-port (addrinfo:addr ai) port) timeout) |
76832d34 | 240 | (setvbuf s 'line) |
457dd86d LC |
241 | |
242 | (dynamic-wind | |
243 | (lambda () #t) | |
244 | (lambda () | |
245 | (%ftp-command "LIST" 150 (ftp-connection-socket conn)) | |
246 | ||
247 | (let loop ((line (read-line s)) | |
248 | (result '())) | |
249 | (cond ((eof-object? line) (reverse result)) | |
250 | ((regexp-exec %ftp-ready-rx line) | |
251 | => | |
252 | (lambda (match) | |
253 | (let ((code (string->number (match:substring match 1)))) | |
254 | (if (= 126 code) | |
255 | (reverse result) | |
256 | (throw 'ftp-error conn "LIST" code))))) | |
257 | (else | |
258 | (loop (read-line s) | |
259 | (match (reverse (string-tokenize line)) | |
260 | ((file _ ... permissions) | |
261 | (let ((type (case (string-ref permissions 0) | |
262 | ((#\d) 'directory) | |
263 | (else 'file)))) | |
264 | (cons (list file type) result))) | |
265 | ((file _ ...) | |
266 | (cons (cons file 'file) result)))))))) | |
267 | (lambda () | |
268 | (close s) | |
269 | (let-values (((code message) (%ftp-listen (ftp-connection-socket conn)))) | |
270 | (or (eqv? code 226) | |
271 | (throw 'ftp-error conn "LIST" code message))))))) | |
272 | ||
9f860595 LC |
273 | (define* (ftp-retr conn file #:optional directory |
274 | #:key timeout) | |
457dd86d LC |
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." | |
278 | (if directory | |
279 | (ftp-chdir conn directory)) | |
280 | ||
281 | ;; Ask for "binary mode". | |
282 | (%ftp-command "TYPE I" 200 (ftp-connection-socket conn)) | |
283 | ||
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))))) | |
289 | (define (terminate) | |
290 | (close s) | |
291 | (let-values (((code message) (%ftp-listen (ftp-connection-socket conn)))) | |
292 | (or (eqv? code 226) | |
293 | (throw 'ftp-error conn "LIST" code message)))) | |
294 | ||
9f860595 | 295 | (connect* s (address-with-port (addrinfo:addr ai) port) timeout) |
76832d34 | 296 | (setvbuf s 'line) |
457dd86d LC |
297 | |
298 | (%ftp-command (string-append "RETR " file) | |
299 | 150 (ftp-connection-socket conn)) | |
300 | ||
301 | (make-custom-binary-input-port "FTP RETR port" | |
302 | (rec (read! bv start count) | |
303 | (match (get-bytevector-n! s bv | |
304 | start count) | |
87dfd455 LC |
305 | ((? eof-object?) 0) |
306 | (0 | |
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)) | |
313 | (read read))) | |
457dd86d LC |
314 | #f #f ; no get/set position |
315 | terminate))) | |
316 | ||
317 | ;;; ftp-client.scm ends here |