-;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
-;;; Copyright (C) 2010, 2011, 2012 Ludovic Courtès <ludo@gnu.org>
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
-;;; This file is part of Guix.
+;;; This file is part of GNU Guix.
;;;
-;;; Guix is free software; you can redistribute it and/or modify it
+;;; 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.
;;;
-;;; Guix is distributed in the hope that it will be useful, but
+;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>.
+;;; 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-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-31)
- #:use-module (rnrs io ports)
+ #:use-module (ice-9 binary-ports)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:export (ftp-connection?
ftp-connection-addrinfo
+ connect*
ftp-open
ftp-close
ftp-chdir
+ ftp-size
ftp-list
ftp-retr))
(throw 'ftp-error port command code message))))
(define (%ftp-login user pass port)
- (let ((command (string-append "USER " user (string #\newline))))
+ (let ((command (string-append "USER " user
+ (string #\return) (string #\newline))))
(display command port)
(let-values (((code message) (%ftp-listen port)))
(case code
((331) (%ftp-command (string-append "PASS " pass) 230 port))
(else (throw 'ftp-error port command code message))))))
-(define* (ftp-open host #:optional (port 21))
+(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 "ftp")
+ #:key timeout
+ (username "anonymous")
+ (password "guix@example.com"))
"Open an FTP connection to HOST on PORT (a service-identifying string,
-or a TCP port number), and return it."
- ;; Use 21 as the default PORT instead of "ftp", to avoid depending on
- ;; libc's NSS, which is not available during bootstrap.
+or a TCP port number), and return it.
- (catch 'getaddrinfo-error
- (lambda ()
- (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) (addrinfo:socktype ai)
- (addrinfo:protocol ai))))
-
- (catch 'system-error
- (lambda ()
- (connect s (addrinfo:addr ai))
- (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
- (format (current-error-port)
- "FTP to `~a' failed: ~A: ~A~%"
- host code message)
- (close s)
- #f))))
-
- (lambda args
- ;; Connection failed, so try one of the other addresses.
- (close s)
- (if (null? addresses)
- (apply throw args)
- (loop (cdr addresses))))))))
- (lambda (key errcode)
- (format (current-error-port) "failed to resolve `~a': ~a~%"
- host (gai-strerror errcode))
- #f)))
+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."
+ ;; Using "ftp" for PORT instead of 21 allows 'getaddrinfo' to return only
+ ;; TCP/IP addresses (otherwise it would return SOCK_DGRAM and SOCK_RAW
+ ;; addresses as well.) With our bootstrap Guile, which includes a
+ ;; statically-linked NSS, resolving "ftp" works well, as long as
+ ;; /etc/services is available.
+
+ (define addresses
+ (getaddrinfo host
+ (if (number? port) (number->string port) port)
+ (if (number? port)
+ (logior AI_ADDRCONFIG AI_NUMERICSERV)
+ AI_ADDRCONFIG)))
+
+ (let loop ((addresses addresses))
+ (match addresses
+ ((ai rest ...)
+ (let ((s (socket (addrinfo:fam ai)
+ ;; TCP/IP only
+ SOCK_STREAM IPPROTO_IP)))
+
+ (catch 'system-error
+ (lambda ()
+ (connect* s (addrinfo:addr ai) timeout)
+ (setvbuf s 'line)
+ (let-values (((code message) (%ftp-listen s)))
+ (if (eqv? code 220)
+ (begin
+ ;;(%ftp-command "OPTS UTF8 ON" 200 s)
+ (%ftp-login username password 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? rest)
+ (apply throw args)
+ (loop rest)))))))))
(define (ftp-close conn)
(close (ftp-connection-socket conn)))
+(define %char-set:not-slash
+ (char-set-complement (char-set #\/)))
+
(define (ftp-chdir conn dir)
- (%ftp-command (string-append "CWD " dir) 250
- (ftp-connection-socket conn)))
+ "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
(sockaddr:scopeid sa)))
(else #f))))
-(define* (ftp-list conn #:optional directory)
+(define* (ftp-list conn #:optional directory #:key timeout)
(if directory
(ftp-chdir conn directory))
(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)
+ (connect* s (address-with-port (addrinfo:addr ai) port) timeout)
+ (setvbuf s 'line)
(dynamic-wind
(lambda () #t)
(or (eqv? code 226)
(throw 'ftp-error conn "LIST" code message)))))))
-(define* (ftp-retr conn file #:optional directory)
+(define* (ftp-retr conn file #:optional directory
+ #:key timeout)
"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."
(or (eqv? code 226)
(throw 'ftp-error conn "LIST" code message))))
- (connect s (address-with-port (addrinfo:addr ai) port))
- (setvbuf s _IOLBF)
+ (connect* s (address-with-port (addrinfo:addr ai) port) timeout)
+ (setvbuf s 'line)
(%ftp-command (string-append "RETR " file)
150 (ftp-connection-socket conn))
(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)))
+ ((? 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)))
HCoop / jackhill / guix / guix.git / blobdiff