guix/ftp-client.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   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 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  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
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  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 (ice-9 binary-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             connect*
  34             ftp-open
  35             ftp-close
  36             ftp-chdir
  37             ftp-size
  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)
  77   (let ((command (string-append "USER " user
  78                                 (string #\return) (string #\newline))))
  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
  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 "ftp")
 125                         #:key timeout
 126                               (username "anonymous")
 127                               (password "guix@example.com"))
 128   "Open an FTP connection to HOST on PORT (a service-identifying string,
 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."
 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.
 139
 140   (define addresses
 141     (getaddrinfo host
 142                  (if (number? port) (number->string port) port)
 143                  (if (number? port)
 144                      (logior AI_ADDRCONFIG AI_NUMERICSERV)
 145                      AI_ADDRCONFIG)))
 146
 147   (let loop ((addresses addresses))
 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)
 157              (setvbuf s 'line)
 158              (let-values (((code message) (%ftp-listen s)))
 159                (if (eqv? code 220)
 160                    (begin
 161                      ;;(%ftp-command "OPTS UTF8 ON" 200 s)
 162                      (%ftp-login username password s)
 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)))))))))
 174
 175 (define (ftp-close conn)
 176   (close (ftp-connection-socket conn)))
 177
 178 (define %char-set:not-slash
 179   (char-set-complement (char-set #\/)))
 180
 181 (define (ftp-chdir conn dir)
 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))))
 194
 195 (define (ftp-size conn file)
 196   "Return the size in bytes of FILE."
 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
 202   (let ((message (%ftp-command (string-append "SIZE " file) 213
 203                                (ftp-connection-socket conn))))
 204     (string->number (string-trim-both message))))
 205
 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
 231 (define* (ftp-list conn #:optional directory #:key timeout)
 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))))
 239     (connect* s (address-with-port (addrinfo:addr ai) port) timeout)
 240     (setvbuf s 'line)
 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
 273 (define* (ftp-retr conn file #:optional directory
 274                    #:key timeout)
 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
 295     (connect* s (address-with-port (addrinfo:addr ai) port) timeout)
 296     (setvbuf s 'line)
 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)
 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)))
 314                                    #f #f          ; no get/set position
 315                                    terminate)))
 316
 317 ;;; ftp-client.scm ends here