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 | ||
33 | ftp-open | |
34 | ftp-close | |
35 | ftp-chdir | |
fb83842e | 36 | ftp-size |
457dd86d LC |
37 | ftp-list |
38 | ftp-retr)) | |
39 | ||
40 | ;;; Commentary: | |
41 | ;;; | |
42 | ;;; Simple FTP client (RFC 959). | |
43 | ;;; | |
44 | ;;; Code: | |
45 | ||
46 | ;; TODO: Use SRFI-3{4,5} error conditions. | |
47 | ||
48 | (define-record-type <ftp-connection> | |
49 | (%make-ftp-connection socket addrinfo) | |
50 | ftp-connection? | |
51 | (socket ftp-connection-socket) | |
52 | (addrinfo ftp-connection-addrinfo)) | |
53 | ||
54 | (define %ftp-ready-rx | |
55 | (make-regexp "^([0-9]{3}) (.+)$")) | |
56 | ||
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) | |
61 | => | |
62 | (lambda (match) | |
63 | (values (string->number (match:substring match 1)) | |
64 | (match:substring match 2)))) | |
65 | (else | |
66 | (loop (read-line port)))))) | |
67 | ||
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) | |
72 | message | |
73 | (throw 'ftp-error port command code message)))) | |
74 | ||
75 | (define (%ftp-login user pass port) | |
3c986b75 LC |
76 | (let ((command (string-append "USER " user |
77 | (string #\return) (string #\newline)))) | |
457dd86d LC |
78 | (display command port) |
79 | (let-values (((code message) (%ftp-listen port))) | |
80 | (case code | |
81 | ((230) #t) | |
82 | ((331) (%ftp-command (string-append "PASS " pass) 230 port)) | |
83 | (else (throw 'ftp-error port command code message)))))) | |
84 | ||
d14ecda9 LC |
85 | (define* (ftp-open host #:optional (port 21)) |
86 | "Open an FTP connection to HOST on PORT (a service-identifying string, | |
87 | or a TCP port number), and return it." | |
88 | ;; Use 21 as the default PORT instead of "ftp", to avoid depending on | |
89 | ;; libc's NSS, which is not available during bootstrap. | |
90 | ||
91fe0e20 LC |
91 | (define addresses |
92 | (getaddrinfo host | |
93 | (if (number? port) (number->string port) port) | |
94 | (if (number? port) AI_NUMERICSERV 0))) | |
95 | ||
96 | (let loop ((addresses addresses)) | |
97 | (let* ((ai (car addresses)) | |
98 | (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) | |
99 | (addrinfo:protocol ai)))) | |
100 | ||
101 | (catch 'system-error | |
102 | (lambda () | |
103 | (connect s (addrinfo:addr ai)) | |
104 | (setvbuf s _IOLBF) | |
105 | (let-values (((code message) (%ftp-listen s))) | |
106 | (if (eqv? code 220) | |
107 | (begin | |
108 | ;;(%ftp-command "OPTS UTF8 ON" 200 s) | |
109 | (%ftp-login "anonymous" "guix@example.com" s) | |
110 | (%make-ftp-connection s ai)) | |
111 | (begin | |
112 | (format (current-error-port) | |
113 | "FTP to `~a' failed: ~A: ~A~%" | |
114 | host code message) | |
115 | (close s) | |
116 | #f)))) | |
117 | ||
118 | (lambda args | |
119 | ;; Connection failed, so try one of the other addresses. | |
120 | (close s) | |
121 | (if (null? addresses) | |
122 | (apply throw args) | |
123 | (loop (cdr addresses)))))))) | |
457dd86d LC |
124 | |
125 | (define (ftp-close conn) | |
126 | (close (ftp-connection-socket conn))) | |
127 | ||
87dfd455 LC |
128 | (define %char-set:not-slash |
129 | (char-set-complement (char-set #\/))) | |
130 | ||
457dd86d | 131 | (define (ftp-chdir conn dir) |
87dfd455 LC |
132 | "Change to directory DIR." |
133 | ||
134 | ;; On ftp.gnupg.org, "PASV" right after "CWD /gcrypt/gnupg" hangs. Doing | |
135 | ;; CWD in two steps works, so just do this. | |
136 | (let ((components (string-tokenize dir %char-set:not-slash))) | |
137 | (fold (lambda (dir result) | |
138 | (%ftp-command (string-append "CWD " dir) 250 | |
139 | (ftp-connection-socket conn))) | |
140 | #f | |
141 | (if (string-prefix? "/" dir) | |
142 | (cons "/" components) | |
143 | components)))) | |
457dd86d | 144 | |
fb83842e LC |
145 | (define (ftp-size conn file) |
146 | "Return the size in bytes of FILE." | |
2a31e1da LC |
147 | |
148 | ;; Ask for "binary mode", otherwise some servers, such as sourceware.org, | |
149 | ;; fail with 550 ("SIZE not allowed in ASCII mode"). | |
150 | (%ftp-command "TYPE I" 200 (ftp-connection-socket conn)) | |
151 | ||
fb83842e LC |
152 | (let ((message (%ftp-command (string-append "SIZE " file) 213 |
153 | (ftp-connection-socket conn)))) | |
154 | (string->number (string-trim-both message)))) | |
155 | ||
457dd86d LC |
156 | (define (ftp-pasv conn) |
157 | (define %pasv-rx | |
158 | (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)")) | |
159 | ||
160 | (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn)))) | |
161 | (cond ((regexp-exec %pasv-rx message) | |
162 | => | |
163 | (lambda (match) | |
164 | (+ (* (string->number (match:substring match 5)) 256) | |
165 | (string->number (match:substring match 6))))) | |
166 | (else | |
167 | (throw 'ftp-error conn "PASV" 227 message))))) | |
168 | ||
169 | (define (address-with-port sa port) | |
170 | "Return a socket-address object based on SA, but with PORT." | |
171 | (let ((fam (sockaddr:fam sa)) | |
172 | (addr (sockaddr:addr sa))) | |
173 | (cond ((= fam AF_INET) | |
174 | (make-socket-address fam addr port)) | |
175 | ((= fam AF_INET6) | |
176 | (make-socket-address fam addr port | |
177 | (sockaddr:flowinfo sa) | |
178 | (sockaddr:scopeid sa))) | |
179 | (else #f)))) | |
180 | ||
181 | (define* (ftp-list conn #:optional directory) | |
182 | (if directory | |
183 | (ftp-chdir conn directory)) | |
184 | ||
185 | (let* ((port (ftp-pasv conn)) | |
186 | (ai (ftp-connection-addrinfo conn)) | |
187 | (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) | |
188 | (addrinfo:protocol ai)))) | |
189 | (connect s (address-with-port (addrinfo:addr ai) port)) | |
190 | (setvbuf s _IOLBF) | |
191 | ||
192 | (dynamic-wind | |
193 | (lambda () #t) | |
194 | (lambda () | |
195 | (%ftp-command "LIST" 150 (ftp-connection-socket conn)) | |
196 | ||
197 | (let loop ((line (read-line s)) | |
198 | (result '())) | |
199 | (cond ((eof-object? line) (reverse result)) | |
200 | ((regexp-exec %ftp-ready-rx line) | |
201 | => | |
202 | (lambda (match) | |
203 | (let ((code (string->number (match:substring match 1)))) | |
204 | (if (= 126 code) | |
205 | (reverse result) | |
206 | (throw 'ftp-error conn "LIST" code))))) | |
207 | (else | |
208 | (loop (read-line s) | |
209 | (match (reverse (string-tokenize line)) | |
210 | ((file _ ... permissions) | |
211 | (let ((type (case (string-ref permissions 0) | |
212 | ((#\d) 'directory) | |
213 | (else 'file)))) | |
214 | (cons (list file type) result))) | |
215 | ((file _ ...) | |
216 | (cons (cons file 'file) result)))))))) | |
217 | (lambda () | |
218 | (close s) | |
219 | (let-values (((code message) (%ftp-listen (ftp-connection-socket conn)))) | |
220 | (or (eqv? code 226) | |
221 | (throw 'ftp-error conn "LIST" code message))))))) | |
222 | ||
223 | (define* (ftp-retr conn file #:optional directory) | |
224 | "Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from | |
225 | FTP connection CONN. Return a binary port to that file. The returned port | |
226 | must be closed before CONN can be used for other purposes." | |
227 | (if directory | |
228 | (ftp-chdir conn directory)) | |
229 | ||
230 | ;; Ask for "binary mode". | |
231 | (%ftp-command "TYPE I" 200 (ftp-connection-socket conn)) | |
232 | ||
233 | (let* ((port (ftp-pasv conn)) | |
234 | (ai (ftp-connection-addrinfo conn)) | |
235 | (s (with-fluids ((%default-port-encoding #f)) | |
236 | (socket (addrinfo:fam ai) (addrinfo:socktype ai) | |
237 | (addrinfo:protocol ai))))) | |
238 | (define (terminate) | |
239 | (close s) | |
240 | (let-values (((code message) (%ftp-listen (ftp-connection-socket conn)))) | |
241 | (or (eqv? code 226) | |
242 | (throw 'ftp-error conn "LIST" code message)))) | |
243 | ||
244 | (connect s (address-with-port (addrinfo:addr ai) port)) | |
245 | (setvbuf s _IOLBF) | |
246 | ||
247 | (%ftp-command (string-append "RETR " file) | |
248 | 150 (ftp-connection-socket conn)) | |
249 | ||
250 | (make-custom-binary-input-port "FTP RETR port" | |
251 | (rec (read! bv start count) | |
252 | (match (get-bytevector-n! s bv | |
253 | start count) | |
87dfd455 LC |
254 | ((? eof-object?) 0) |
255 | (0 | |
256 | ;; Nothing available yet, so try | |
257 | ;; again. This is important because | |
258 | ;; the return value of `read!' makes | |
259 | ;; it impossible to distinguish | |
260 | ;; between "not yet" and "EOF". | |
261 | (read! bv start count)) | |
262 | (read read))) | |
457dd86d LC |
263 | #f #f ; no get/set position |
264 | terminate))) | |
265 | ||
266 | ;;; ftp-client.scm ends here |