aboutsummaryrefslogtreecommitdiff
path: root/guix/ftp-client.scm
blob: 761980ac8f276b6a62fbfaf57d2964264b041d31 (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
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014 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 (rnrs io 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

            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* (ftp-open host #:optional (port 21))
  "Open an FTP connection to HOST on PORT (a service-identifying string,
or a TCP port number), and return it."
  ;; Use 21 as the default PORT instead of "ftp", to avoid depending on
  ;; libc's NSS, which is not available during bootstrap.

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

  (let loop ((addresses addresses))
    (let* ((ai (car addresses))
           (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
                       (addrinfo:protocol ai))))

      (catch 'system-error
        (lambda ()
          (connect s (addrinfo:addr ai))
          (setvbuf s _IOLBF)
          (let-values (((code message) (%ftp-listen s)))
            (if (eqv? code 220)
                (begin
                  ;;(%ftp-command "OPTS UTF8 ON" 200 s)
                  (%ftp-login "anonymous" "guix@example.com" s)
                  (%make-ftp-connection s ai))
                (begin
                  (format (current-error-port)
                          "FTP to `~a' failed: ~A: ~A~%"
                          host code message)
                  (close s)
                  #f))))

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

(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."
  (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