[jackhill/guix/guix.git] / guix / ftp-client.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 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

            connect*
            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-syntax-rule (catch-EINPROGRESS body ...)
  (catch 'system-error
    (lambda ()
      body ...)
    (lambda args
      (unless (= (system-error-errno args) EINPROGRESS)
        (apply throw args)))))

;; XXX: For lack of a better place.
(define* (connect* s sockaddr #:optional timeout)
  "When TIMEOUT is omitted or #f, this procedure is equivalent to 'connect'.
When TIMEOUT is a number, it is the (possibly inexact) maximum number of
seconds to wait for the connection to succeed."
  (define (raise-error errno)
    (throw 'system-error 'connect* "~A"
           (list (strerror errno))
           (list errno)))

  (if timeout
      (let ((flags (fcntl s F_GETFL)))
        (fcntl s F_SETFL (logior flags O_NONBLOCK))
        (catch-EINPROGRESS (connect s sockaddr))
        (match (select '() (list s) (list s) timeout)
          ((() () ())
           ;; Time is up!
           (raise-error ETIMEDOUT))
          ((() (write) ())
           ;; Check for ECONNREFUSED and the likes.
           (fcntl s F_SETFL flags)
           (let ((errno (getsockopt s SOL_SOCKET SO_ERROR)))
             (unless (zero? errno)
               (raise-error errno))))
          ((() () (except))
           ;; Seems like this cannot really happen, but who knows.
           (let ((errno (getsockopt s SOL_SOCKET SO_ERROR)))
             (raise-error errno)))))
      (connect s sockaddr)))

(define* (ftp-open host #:optional (port 21) #:key timeout)
  "Open an FTP connection to HOST on PORT (a service-identifying string,
or a TCP port number), and return it.

When TIMEOUT is not #f, it must be a (possibly inexact) number denoting the
maximum duration in seconds to wait for the connection to complete; passed
TIMEOUT, an ETIMEDOUT error is raised."
  ;; 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) SOCK_STREAM ;TCP only
                       (addrinfo:protocol ai))))

      (catch 'system-error
        (lambda ()
          (connect* s (addrinfo:addr ai) timeout)
          (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
                  (close s)
                  (throw 'ftp-error s "log-in" code message)))))

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

  ;; Ask for "binary mode", otherwise some servers, such as sourceware.org,
  ;; fail with 550 ("SIZE not allowed in ASCII mode").
  (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))

  (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
Commit	Line	Data
233e7676	1	;;; GNU Guix --- Functional package management for GNU
2a31e1da	2	;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
457dd86d	3	;;;
233e7676	4	;;; This file is part of GNU Guix.
457dd86d	5	;;;
233e7676	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
457dd86d LC	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	;;;
233e7676	11	;;; GNU Guix is distributed in the hope that it will be useful, but
457dd86d LC	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
233e7676	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
457dd86d LC	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
48567006	33	connect*
457dd86d LC	34	ftp-open
	35	ftp-close
	36	ftp-chdir
fb83842e	37	ftp-size
457dd86d LC	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)
3c986b75 LC	77	(let ((command (string-append "USER " user
3c986b75 LC	78	(string #\return) (string #\newline))))
457dd86d LC	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
48567006 LC	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 21) #:key timeout)
d14ecda9	125	"Open an FTP connection to HOST on PORT (a service-identifying string,
48567006 LC	126	or a TCP port number), and return it.
	127
	128	When TIMEOUT is not #f, it must be a (possibly inexact) number denoting the
	129	maximum duration in seconds to wait for the connection to complete; passed
	130	TIMEOUT, an ETIMEDOUT error is raised."
d14ecda9 LC	131	;; Use 21 as the default PORT instead of "ftp", to avoid depending on
	132	;; libc's NSS, which is not available during bootstrap.
	133
91fe0e20 LC	134	(define addresses
	135	(getaddrinfo host
	136	(if (number? port) (number->string port) port)
	137	(if (number? port) AI_NUMERICSERV 0)))
	138
	139	(let loop ((addresses addresses))
	140	(let* ((ai (car addresses))
279ec1df	141	(s (socket (addrinfo:fam ai) SOCK_STREAM ;TCP only
91fe0e20 LC	142	(addrinfo:protocol ai))))
	143
	144	(catch 'system-error
	145	(lambda ()
48567006	146	(connect* s (addrinfo:addr ai) timeout)
91fe0e20 LC	147	(setvbuf s _IOLBF)
	148	(let-values (((code message) (%ftp-listen s)))
	149	(if (eqv? code 220)
	150	(begin
	151	;;(%ftp-command "OPTS UTF8 ON" 200 s)
	152	(%ftp-login "anonymous" "guix@example.com" s)
	153	(%make-ftp-connection s ai))
	154	(begin
91fe0e20	155	(close s)
820a4032	156	(throw 'ftp-error s "log-in" code message)))))
91fe0e20 LC	157
	158	(lambda args
	159	;; Connection failed, so try one of the other addresses.
	160	(close s)
	161	(if (null? addresses)
	162	(apply throw args)
	163	(loop (cdr addresses))))))))
457dd86d LC	164
	165	(define (ftp-close conn)
	166	(close (ftp-connection-socket conn)))
	167
87dfd455 LC	168	(define %char-set:not-slash
	169	(char-set-complement (char-set #\/)))
	170
457dd86d	171	(define (ftp-chdir conn dir)
87dfd455 LC	172	"Change to directory DIR."
	173
	174	;; On ftp.gnupg.org, "PASV" right after "CWD /gcrypt/gnupg" hangs. Doing
	175	;; CWD in two steps works, so just do this.
	176	(let ((components (string-tokenize dir %char-set:not-slash)))
	177	(fold (lambda (dir result)
	178	(%ftp-command (string-append "CWD " dir) 250
	179	(ftp-connection-socket conn)))
	180	#f
	181	(if (string-prefix? "/" dir)
	182	(cons "/" components)
	183	components))))
457dd86d	184
fb83842e LC	185	(define (ftp-size conn file)
fb83842e LC	186	"Return the size in bytes of FILE."
2a31e1da LC	187
	188	;; Ask for "binary mode", otherwise some servers, such as sourceware.org,
	189	;; fail with 550 ("SIZE not allowed in ASCII mode").
	190	(%ftp-command "TYPE I" 200 (ftp-connection-socket conn))
	191
fb83842e LC	192	(let ((message (%ftp-command (string-append "SIZE " file) 213
	193	(ftp-connection-socket conn))))
	194	(string->number (string-trim-both message))))
	195
457dd86d LC	196	(define (ftp-pasv conn)
	197	(define %pasv-rx
	198	(make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))
	199
	200	(let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
	201	(cond ((regexp-exec %pasv-rx message)
	202	=>
	203	(lambda (match)
	204	(+ (* (string->number (match:substring match 5)) 256)
	205	(string->number (match:substring match 6)))))
	206	(else
	207	(throw 'ftp-error conn "PASV" 227 message)))))
	208
	209	(define (address-with-port sa port)
	210	"Return a socket-address object based on SA, but with PORT."
	211	(let ((fam (sockaddr:fam sa))
	212	(addr (sockaddr:addr sa)))
	213	(cond ((= fam AF_INET)
	214	(make-socket-address fam addr port))
	215	((= fam AF_INET6)
	216	(make-socket-address fam addr port
	217	(sockaddr:flowinfo sa)
	218	(sockaddr:scopeid sa)))
	219	(else #f))))
	220
	221	(define* (ftp-list conn #:optional directory)
	222	(if directory
	223	(ftp-chdir conn directory))
	224
	225	(let* ((port (ftp-pasv conn))
	226	(ai (ftp-connection-addrinfo conn))
	227	(s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
	228	(addrinfo:protocol ai))))
	229	(connect s (address-with-port (addrinfo:addr ai) port))
	230	(setvbuf s _IOLBF)
	231
	232	(dynamic-wind
	233	(lambda () #t)
	234	(lambda ()
	235	(%ftp-command "LIST" 150 (ftp-connection-socket conn))
	236
	237	(let loop ((line (read-line s))
	238	(result '()))
	239	(cond ((eof-object? line) (reverse result))
	240	((regexp-exec %ftp-ready-rx line)
	241	=>
	242	(lambda (match)
	243	(let ((code (string->number (match:substring match 1))))
	244	(if (= 126 code)
	245	(reverse result)
	246	(throw 'ftp-error conn "LIST" code)))))
	247	(else
	248	(loop (read-line s)
	249	(match (reverse (string-tokenize line))
	250	((file _ ... permissions)
	251	(let ((type (case (string-ref permissions 0)
	252	((#\d) 'directory)
	253	(else 'file))))
	254	(cons (list file type) result)))
	255	((file _ ...)
	256	(cons (cons file 'file) result))))))))
	257	(lambda ()
	258	(close s)
	259	(let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
260	(or (eqv? code 226)
261	(throw 'ftp-error conn "LIST" code message)))))))
262
263	(define* (ftp-retr conn file #:optional directory)
264	"Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from
265	FTP connection CONN. Return a binary port to that file. The returned port
266	must be closed before CONN can be used for other purposes."
267	(if directory
268	(ftp-chdir conn directory))
269
270	;; Ask for "binary mode".
271	(%ftp-command "TYPE I" 200 (ftp-connection-socket conn))
272
273	(let* ((port (ftp-pasv conn))
274	(ai (ftp-connection-addrinfo conn))
275	(s (with-fluids ((%default-port-encoding #f))
276	(socket (addrinfo:fam ai) (addrinfo:socktype ai)
277	(addrinfo:protocol ai)))))
278	(define (terminate)
279	(close s)
280	(let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
281	(or (eqv? code 226)
282	(throw 'ftp-error conn "LIST" code message))))
283
284	(connect s (address-with-port (addrinfo:addr ai) port))
285	(setvbuf s _IOLBF)
286
287	(%ftp-command (string-append "RETR " file)
288	150 (ftp-connection-socket conn))
289
290	(make-custom-binary-input-port "FTP RETR port"
291	(rec (read! bv start count)
292	(match (get-bytevector-n! s bv
293	start count)
87dfd455 LC	294	((? eof-object?) 0)
	295	(0
	296	;; Nothing available yet, so try
	297	;; again. This is important because
	298	;; the return value of `read!' makes
	299	;; it impossible to distinguish
	300	;; between "not yet" and "EOF".
	301	(read! bv start count))
	302	(read read)))
457dd86d LC	303	#f #f ; no get/set position
	304	terminate)))
	305
	306	;;; ftp-client.scm ends here