guix/ftp-client.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 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 (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
  36             ftp-size
  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)
  76   (let ((command (string-append "USER " user
  77                                 (string #\return) (string #\newline))))
  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
  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
  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))))))))
 124
 125 (define (ftp-close conn)
 126   (close (ftp-connection-socket conn)))
 127
 128 (define %char-set:not-slash
 129   (char-set-complement (char-set #\/)))
 130
 131 (define (ftp-chdir conn dir)
 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))))
 144
 145 (define (ftp-size conn file)
 146   "Return the size in bytes of FILE."
 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
 152   (let ((message (%ftp-command (string-append "SIZE " file) 213
 153                                (ftp-connection-socket conn))))
 154     (string->number (string-trim-both message))))
 155
 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)
 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)))
 263                                    #f #f          ; no get/set position
 264                                    terminate)))
 265
 266 ;;; ftp-client.scm ends here