guix/ftp-client.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013 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 (string #\newline))))
  77     (display command port)
  78     (let-values (((code message) (%ftp-listen port)))
  79       (case code
  80         ((230)  #t)
  81         ((331) (%ftp-command (string-append "PASS " pass) 230 port))
  82         (else  (throw 'ftp-error port command code message))))))
  83
  84 (define* (ftp-open host #:optional (port 21))
  85   "Open an FTP connection to HOST on PORT (a service-identifying string,
  86 or a TCP port number), and return it."
  87   ;; Use 21 as the default PORT instead of "ftp", to avoid depending on
  88   ;; libc's NSS, which is not available during bootstrap.
  89
  90   (catch 'getaddrinfo-error
  91     (lambda ()
  92       (define addresses
  93         (getaddrinfo host
  94                      (if (number? port) (number->string port) port)
  95                      (if (number? port) AI_NUMERICSERV 0)))
  96
  97       (let loop ((addresses addresses))
  98         (let* ((ai (car addresses))
  99                (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
 100                            (addrinfo:protocol ai))))
 101
 102           (catch 'system-error
 103             (lambda ()
 104               (connect s (addrinfo:addr ai))
 105               (setvbuf s _IOLBF)
 106               (let-values (((code message) (%ftp-listen s)))
 107                 (if (eqv? code 220)
 108                     (begin
 109                       ;;(%ftp-command "OPTS UTF8 ON" 200 s)
 110                       (%ftp-login "anonymous" "guix@example.com" s)
 111                       (%make-ftp-connection s ai))
 112                     (begin
 113                       (format (current-error-port)
 114                               "FTP to `~a' failed: ~A: ~A~%"
 115                               host code message)
 116                       (close s)
 117                       #f))))
 118
 119             (lambda args
 120               ;; Connection failed, so try one of the other addresses.
 121               (close s)
 122               (if (null? addresses)
 123                   (apply throw args)
 124                   (loop (cdr addresses))))))))
 125     (lambda (key errcode)
 126       (format (current-error-port) "failed to resolve `~a': ~a~%"
 127               host (gai-strerror errcode))
 128       #f)))
 129
 130 (define (ftp-close conn)
 131   (close (ftp-connection-socket conn)))
 132
 133 (define (ftp-chdir conn dir)
 134   (%ftp-command (string-append "CWD " dir) 250
 135                 (ftp-connection-socket conn)))
 136
 137 (define (ftp-size conn file)
 138   "Return the size in bytes of FILE."
 139   (let ((message (%ftp-command (string-append "SIZE " file) 213
 140                                (ftp-connection-socket conn))))
 141     (string->number (string-trim-both message))))
 142
 143 (define (ftp-pasv conn)
 144   (define %pasv-rx
 145     (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))
 146
 147   (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
 148     (cond ((regexp-exec %pasv-rx message)
 149            =>
 150            (lambda (match)
 151              (+ (* (string->number (match:substring match 5)) 256)
 152                 (string->number (match:substring match 6)))))
 153           (else
 154            (throw 'ftp-error conn "PASV" 227 message)))))
 155
 156 (define (address-with-port sa port)
 157   "Return a socket-address object based on SA, but with PORT."
 158   (let ((fam  (sockaddr:fam sa))
 159         (addr (sockaddr:addr sa)))
 160     (cond ((= fam AF_INET)
 161            (make-socket-address fam addr port))
 162           ((= fam AF_INET6)
 163            (make-socket-address fam addr port
 164                                 (sockaddr:flowinfo sa)
 165                                 (sockaddr:scopeid sa)))
 166           (else #f))))
 167
 168 (define* (ftp-list conn #:optional directory)
 169   (if directory
 170       (ftp-chdir conn directory))
 171
 172   (let* ((port (ftp-pasv conn))
 173          (ai   (ftp-connection-addrinfo conn))
 174          (s    (socket (addrinfo:fam ai) (addrinfo:socktype ai)
 175                        (addrinfo:protocol ai))))
 176     (connect s (address-with-port (addrinfo:addr ai) port))
 177     (setvbuf s _IOLBF)
 178
 179     (dynamic-wind
 180       (lambda () #t)
 181       (lambda ()
 182         (%ftp-command "LIST" 150 (ftp-connection-socket conn))
 183
 184         (let loop ((line   (read-line s))
 185                    (result '()))
 186           (cond ((eof-object? line) (reverse result))
 187                 ((regexp-exec %ftp-ready-rx line)
 188                  =>
 189                  (lambda (match)
 190                    (let ((code (string->number (match:substring match 1))))
 191                      (if (= 126 code)
 192                          (reverse result)
 193                          (throw 'ftp-error conn "LIST" code)))))
 194                 (else
 195                  (loop (read-line s)
 196                        (match (reverse (string-tokenize line))
 197                          ((file _ ... permissions)
 198                           (let ((type (case (string-ref permissions 0)
 199                                         ((#\d) 'directory)
 200                                         (else 'file))))
 201                             (cons (list file type) result)))
 202                          ((file _ ...)
 203                           (cons (cons file 'file) result))))))))
 204       (lambda ()
 205         (close s)
 206         (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
 207           (or (eqv? code 226)
 208               (throw 'ftp-error conn "LIST" code message)))))))
 209
 210 (define* (ftp-retr conn file #:optional directory)
 211   "Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from
 212 FTP connection CONN.  Return a binary port to that file.  The returned port
 213 must be closed before CONN can be used for other purposes."
 214   (if directory
 215       (ftp-chdir conn directory))
 216
 217   ;; Ask for "binary mode".
 218   (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))
 219
 220   (let* ((port (ftp-pasv conn))
 221          (ai   (ftp-connection-addrinfo conn))
 222          (s    (with-fluids ((%default-port-encoding #f))
 223                  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
 224                          (addrinfo:protocol ai)))))
 225     (define (terminate)
 226       (close s)
 227       (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
 228         (or (eqv? code 226)
 229             (throw 'ftp-error conn "LIST" code message))))
 230
 231     (connect s (address-with-port (addrinfo:addr ai) port))
 232     (setvbuf s _IOLBF)
 233
 234     (%ftp-command (string-append "RETR " file)
 235                   150 (ftp-connection-socket conn))
 236
 237     (make-custom-binary-input-port "FTP RETR port"
 238                                    (rec (read! bv start count)
 239                                         (match (get-bytevector-n! s bv
 240                                                                   start count)
 241                                        ((? eof-object?) 0)
 242                                        (0
 243                                         ;; Nothing available yet, so try
 244                                         ;; again.  This is important because
 245                                         ;; the return value of `read!' makes
 246                                         ;; it impossible to distinguish
 247                                         ;; between "not yet" and "EOF".
 248                                         (read! bv start count))
 249                                        (read read)))
 250                                    #f #f          ; no get/set position
 251                                    terminate)))
 252
 253 ;;; ftp-client.scm ends here