summaryrefslogtreecommitdiff
path: root/guix/ftp-client.scm
blob: 054a00ad7fdc3e5bf8eb9e1a8d292ded6213c55d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix ftp-client)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-31)
  #:use-module (ice-9 binary-ports)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:export (ftp-connection?
            ftp-connection-addrinfo

            connect*
            ftp-open
            ftp-close
            ftp-chdir
            ftp-size
            ftp-list
            ftp-retr))

;;; Commentary:
;;;
;;; Simple FTP client (RFC 959).
;;;
;;; Code:

;; TODO: Use SRFI-3{4,5} error conditions.

(define-record-type <ftp-connection>
  (%make-ftp-connection socket addrinfo)
  ftp-connection?
  (socket    ftp-connection-socket)
  (addrinfo  ftp-connection-addrinfo))

(define %ftp-ready-rx
  (make-regexp "^([0-9]{3}) (.+)$"))

(define (%ftp-listen port)
  (let loop ((line (read-line port)))
    (cond ((eof-object? line) (values line #f))
          ((regexp-exec %ftp-ready-rx line)
           =>
           (lambda (match)
             (values (string->number (match:substring match 1))
                     (match:substring match 2))))
          (else
           (loop (read-line port))))))

(define (%ftp-command command expected-code port)
  (format port "~A~A~A" command (string #\return) (string #\newline))
  (let-values (((code message) (%ftp-listen port)))
    (if (eqv? code expected-code)
        message
        (throw 'ftp-error port command code message))))

(define (%ftp-login user pass port)
  (let ((command (string-append "USER " user
                                (string #\return) (string #\newline))))
    (display command port)
    (let-values (((code message) (%ftp-listen port)))
      (case code
        ((230)  #t)
        ((331) (%ftp-command (string-append "PASS " pass) 230 port))
        (else  (throw 'ftp-error port command code message))))))

(define-syntax-rule (catch-EINPROGRESS body ...)
  (catch 'system-error
    (lambda ()
      body ...)
    (lambda args
      (unless (= (system-error-errno args) EINPROGRESS)
        (apply throw args)))))

;; XXX: For lack of a better place.
(define* (connect* s sockaddr #:optional timeout)
  "When TIMEOUT is omitted or #f, this procedure is equivalent to 'connect'.
When TIMEOUT is a number, it is the (possibly inexact) maximum number of
seconds to wait for the connection to succeed."
  (define (raise-error errno)
    (throw 'system-error 'connect* "~A"
           (list (strerror errno))
           (list errno)))

  (if timeout
      (let ((flags (fcntl s F_GETFL)))
        (fcntl s F_SETFL (logior flags O_NONBLOCK))
        (catch-EINPROGRESS (connect s sockaddr))
        (match (select '() (list s) (list s) timeout)
          ((() () ())
           ;; Time is up!
           (raise-error ETIMEDOUT))
          ((() (write) ())
           ;; Check for ECONNREFUSED and the likes.
           (fcntl s F_SETFL flags)
           (let ((errno (getsockopt s SOL_SOCKET SO_ERROR)))
             (unless (zero? errno)
               (raise-error errno))))
          ((() () (except))
           ;; Seems like this cannot really happen, but who knows.
           (let ((errno (getsockopt s SOL_SOCKET SO_ERROR)))
             (raise-error errno)))))
      (connect s sockaddr)))

(define* (ftp-open host #:optional (port "ftp")
                        #:key timeout
                              (username "anonymous")
                              (password "guix@example.com"))
  "Open an FTP connection to HOST on PORT (a service-identifying string,
or a TCP port number), and return it.

When TIMEOUT is not #f, it must be a (possibly inexact) number denoting the
maximum duration in seconds to wait for the connection to complete; passed
TIMEOUT, an ETIMEDOUT error is raised."
  ;; Using "ftp" for PORT instead of 21 allows 'getaddrinfo' to return only
  ;; TCP/IP addresses (otherwise it would return SOCK_DGRAM and SOCK_RAW
  ;; addresses as well.)  With our bootstrap Guile, which includes a
  ;; statically-linked NSS, resolving "ftp" works well, as long as
  ;; /etc/services is available.

  (define addresses
    (getaddrinfo host
                 (if (number? port) (number->string port) port)
                 (if (number? port)
                     (logior AI_ADDRCONFIG AI_NUMERICSERV)
                     AI_ADDRCONFIG)))

  (let loop ((addresses addresses))
    (match addresses
      ((ai rest ...)
       (let ((s (socket (addrinfo:fam ai)
                        ;; TCP/IP only
                        SOCK_STREAM IPPROTO_IP)))

         (catch 'system-error
           (lambda ()
             (connect* s (addrinfo:addr ai) timeout)
             (setvbuf s _IOLBF)
             (let-values (((code message) (%ftp-listen s)))
               (if (eqv? code 220)
                   (begin
                     ;;(%ftp-command "OPTS UTF8 ON" 200 s)
                     (%ftp-login username password s)
                     (%make-ftp-connection s ai))
                   (begin
                     (close s)
                     (throw 'ftp-error s "log-in" code message)))))

           (lambda args
             ;; Connection failed, so try one of the other addresses.
             (close s)
             (if (null? rest)
                 (apply throw args)
                 (loop rest)))))))))

(define (ftp-close conn)
  (close (ftp-connection-socket conn)))

(define %char-set:not-slash
  (char-set-complement (char-set #\/)))

(define (ftp-chdir conn dir)
  "Change to directory DIR."

  ;; On ftp.gnupg.org, "PASV" right after "CWD /gcrypt/gnupg" hangs.  Doing
  ;; CWD in two steps works, so just do this.
  (let ((components (string-tokenize dir %char-set:not-slash)))
    (fold (lambda (dir result)
            (%ftp-command (string-append "CWD " dir) 250
                          (ftp-connection-socket conn)))
          #f
          (if (string-prefix? "/" dir)
              (cons "/" components)
              components))))

(define (ftp-size conn file)
  "Return the size in bytes of FILE."

  ;; Ask for "binary mode", otherwise some servers, such as sourceware.org,
  ;; fail with 550 ("SIZE not allowed in ASCII mode").
  (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))

  (let ((message (%ftp-command (string-append "SIZE " file) 213
                               (ftp-connection-socket conn))))
    (string->number (string-trim-both message))))

(define (ftp-pasv conn)
  (define %pasv-rx
    (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))

  (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
    (cond ((regexp-exec %pasv-rx message)
           =>
           (lambda (match)
             (+ (* (string->number (match:substring match 5)) 256)
                (string->number (match:substring match 6)))))
          (else
           (throw 'ftp-error conn "PASV" 227 message)))))

(define (address-with-port sa port)
  "Return a socket-address object based on SA, but with PORT."
  (let ((fam  (sockaddr:fam sa))
        (addr (sockaddr:addr sa)))
    (cond ((= fam AF_INET)
           (make-socket-address fam addr port))
          ((= fam AF_INET6)
           (make-socket-address fam addr port
                                (sockaddr:flowinfo sa)
                                (sockaddr:scopeid sa)))
          (else #f))))

(define* (ftp-list conn #:optional directory)
  (if directory
      (ftp-chdir conn directory))

  (let* ((port (ftp-pasv conn))
         (ai   (ftp-connection-addrinfo conn))
         (s    (socket (addrinfo:fam ai) (addrinfo:socktype ai)
                       (addrinfo:protocol ai))))
    (connect s (address-with-port (addrinfo:addr ai) port))
    (setvbuf s _IOLBF)

    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (%ftp-command "LIST" 150 (ftp-connection-socket conn))

        (let loop ((line   (read-line s))
                   (result '()))
          (cond ((eof-object? line) (reverse result))
                ((regexp-exec %ftp-ready-rx line)
                 =>
                 (lambda (match)
                   (let ((code (string->number (match:substring match 1))))
                     (if (= 126 code)
                         (reverse result)
                         (throw 'ftp-error conn "LIST" code)))))
                (else
                 (loop (read-line s)
                       (match (reverse (string-tokenize line))
                         ((file _ ... permissions)
                          (let ((type (case (string-ref permissions 0)
                                        ((#\d) 'directory)
                                        (else 'file))))
                            (cons (list file type) result)))
                         ((file _ ...)
                          (cons (cons file 'file) result))))))))
      (lambda ()
        (close s)
        (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
          (or (eqv? code 226)
              (throw 'ftp-error conn "LIST" code message)))))))

(define* (ftp-retr conn file #:optional directory)
  "Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from
FTP connection CONN.  Return a binary port to that file.  The returned port
must be closed before CONN can be used for other purposes."
  (if directory
      (ftp-chdir conn directory))

  ;; Ask for "binary mode".
  (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))

  (let* ((port (ftp-pasv conn))
         (ai   (ftp-connection-addrinfo conn))
         (s    (with-fluids ((%default-port-encoding #f))
                 (socket (addrinfo:fam ai) (addrinfo:socktype ai)
                         (addrinfo:protocol ai)))))
    (define (terminate)
      (close s)
      (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
        (or (eqv? code 226)
            (throw 'ftp-error conn "LIST" code message))))

    (connect s (address-with-port (addrinfo:addr ai) port))
    (setvbuf s _IOLBF)

    (%ftp-command (string-append "RETR " file)
                  150 (ftp-connection-socket conn))

    (make-custom-binary-input-port "FTP RETR port"
                                   (rec (read! bv start count)
                                        (match (get-bytevector-n! s bv
                                                                  start count)
                                          ((? eof-object?) 0)
                                          (0
                                           ;; Nothing available yet, so try
                                           ;; again.  This is important because
                                           ;; the return value of `read!' makes
                                           ;; it impossible to distinguish
                                           ;; between "not yet" and "EOF".
                                           (read! bv start count))
                                          (read read)))
                                   #f #f          ; no get/set position
                                   terminate)))

;;; ftp-client.scm ends here