guix/ftp-client.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012 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-list
  37             ftp-retr))
  38
  39 ;;; Commentary:
  40 ;;;
  41 ;;; Simple FTP client (RFC 959).
  42 ;;;
  43 ;;; Code:
  44
  45 ;; TODO: Use SRFI-3{4,5} error conditions.
  46
  47 (define-record-type <ftp-connection>
  48   (%make-ftp-connection socket addrinfo)
  49   ftp-connection?
  50   (socket    ftp-connection-socket)
  51   (addrinfo  ftp-connection-addrinfo))
  52
  53 (define %ftp-ready-rx
  54   (make-regexp "^([0-9]{3}) (.+)$"))
  55
  56 (define (%ftp-listen port)
  57   (let loop ((line (read-line port)))
  58     (cond ((eof-object? line) (values line #f))
  59           ((regexp-exec %ftp-ready-rx line)
  60            =>
  61            (lambda (match)
  62              (values (string->number (match:substring match 1))
  63                      (match:substring match 2))))
  64           (else
  65            (loop (read-line port))))))
  66
  67 (define (%ftp-command command expected-code port)
  68   (format port "~A~A~A" command (string #\return) (string #\newline))
  69   (let-values (((code message) (%ftp-listen port)))
  70     (if (eqv? code expected-code)
  71         message
  72         (throw 'ftp-error port command code message))))
  73
  74 (define (%ftp-login user pass port)
  75   (let ((command (string-append "USER " user (string #\newline))))
  76     (display command port)
  77     (let-values (((code message) (%ftp-listen port)))
  78       (case code
  79         ((230)  #t)
  80         ((331) (%ftp-command (string-append "PASS " pass) 230 port))
  81         (else  (throw 'ftp-error port command code message))))))
  82
  83 (define* (ftp-open host #:optional (port 21))
  84   "Open an FTP connection to HOST on PORT (a service-identifying string,
  85 or a TCP port number), and return it."
  86   ;; Use 21 as the default PORT instead of "ftp", to avoid depending on
  87   ;; libc's NSS, which is not available during bootstrap.
  88
  89   (catch 'getaddrinfo-error
  90     (lambda ()
  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     (lambda (key errcode)
 125       (format (current-error-port) "failed to resolve `~a': ~a~%"
 126               host (gai-strerror errcode))
 127       #f)))
 128
 129 (define (ftp-close conn)
 130   (close (ftp-connection-socket conn)))
 131
 132 (define (ftp-chdir conn dir)
 133   (%ftp-command (string-append "CWD " dir) 250
 134                 (ftp-connection-socket conn)))
 135
 136 (define (ftp-pasv conn)
 137   (define %pasv-rx
 138     (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))
 139
 140   (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
 141     (cond ((regexp-exec %pasv-rx message)
 142            =>
 143            (lambda (match)
 144              (+ (* (string->number (match:substring match 5)) 256)
 145                 (string->number (match:substring match 6)))))
 146           (else
 147            (throw 'ftp-error conn "PASV" 227 message)))))
 148
 149 (define (address-with-port sa port)
 150   "Return a socket-address object based on SA, but with PORT."
 151   (let ((fam  (sockaddr:fam sa))
 152         (addr (sockaddr:addr sa)))
 153     (cond ((= fam AF_INET)
 154            (make-socket-address fam addr port))
 155           ((= fam AF_INET6)
 156            (make-socket-address fam addr port
 157                                 (sockaddr:flowinfo sa)
 158                                 (sockaddr:scopeid sa)))
 159           (else #f))))
 160
 161 (define* (ftp-list conn #:optional directory)
 162   (if directory
 163       (ftp-chdir conn directory))
 164
 165   (let* ((port (ftp-pasv conn))
 166          (ai   (ftp-connection-addrinfo conn))
 167          (s    (socket (addrinfo:fam ai) (addrinfo:socktype ai)
 168                        (addrinfo:protocol ai))))
 169     (connect s (address-with-port (addrinfo:addr ai) port))
 170     (setvbuf s _IOLBF)
 171
 172     (dynamic-wind
 173       (lambda () #t)
 174       (lambda ()
 175         (%ftp-command "LIST" 150 (ftp-connection-socket conn))
 176
 177         (let loop ((line   (read-line s))
 178                    (result '()))
 179           (cond ((eof-object? line) (reverse result))
 180                 ((regexp-exec %ftp-ready-rx line)
 181                  =>
 182                  (lambda (match)
 183                    (let ((code (string->number (match:substring match 1))))
 184                      (if (= 126 code)
 185                          (reverse result)
 186                          (throw 'ftp-error conn "LIST" code)))))
 187                 (else
 188                  (loop (read-line s)
 189                        (match (reverse (string-tokenize line))
 190                          ((file _ ... permissions)
 191                           (let ((type (case (string-ref permissions 0)
 192                                         ((#\d) 'directory)
 193                                         (else 'file))))
 194                             (cons (list file type) result)))
 195                          ((file _ ...)
 196                           (cons (cons file 'file) result))))))))
 197       (lambda ()
 198         (close s)
 199         (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
 200           (or (eqv? code 226)
 201               (throw 'ftp-error conn "LIST" code message)))))))
 202
 203 (define* (ftp-retr conn file #:optional directory)
 204   "Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from
 205 FTP connection CONN.  Return a binary port to that file.  The returned port
 206 must be closed before CONN can be used for other purposes."
 207   (if directory
 208       (ftp-chdir conn directory))
 209
 210   ;; Ask for "binary mode".
 211   (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))
 212
 213   (let* ((port (ftp-pasv conn))
 214          (ai   (ftp-connection-addrinfo conn))
 215          (s    (with-fluids ((%default-port-encoding #f))
 216                  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
 217                          (addrinfo:protocol ai)))))
 218     (define (terminate)
 219       (close s)
 220       (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
 221         (or (eqv? code 226)
 222             (throw 'ftp-error conn "LIST" code message))))
 223
 224     (connect s (address-with-port (addrinfo:addr ai) port))
 225     (setvbuf s _IOLBF)
 226
 227     (%ftp-command (string-append "RETR " file)
 228                   150 (ftp-connection-socket conn))
 229
 230     (make-custom-binary-input-port "FTP RETR port"
 231                                    (rec (read! bv start count)
 232                                         (match (get-bytevector-n! s bv
 233                                                                   start count)
 234                                        ((? eof-object?) 0)
 235                                        (0
 236                                         ;; Nothing available yet, so try
 237                                         ;; again.  This is important because
 238                                         ;; the return value of `read!' makes
 239                                         ;; it impossible to distinguish
 240                                         ;; between "not yet" and "EOF".
 241                                         (read! bv start count))
 242                                        (read read)))
 243                                    #f #f          ; no get/set position
 244                                    terminate)))
 245
 246 ;;; ftp-client.scm ends here