Add (guix ftp) and companion modules.

* guix/ftp-client.scm, guix/ftp.scm, guix/build/ftp.scm: New files.
* Makefile.am (MODULES): Add them.

* distro/base.scm (libffi): Use `ftp-fetch'.

5 files changed, 328 insertions, 3 deletions

diff --git a/Makefile.am b/Makefile.am
index 636fd39fe8..fd1e004911 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -24,9 +24,12 @@ MODULES =					\
   guix/build-system.scm				\
   guix/build-system/gnu.scm			\
   guix/build-system/trivial.scm			\
+  guix/ftp.scm					\
+  guix/ftp-client.scm				\
   guix/http.scm					\
   guix/store.scm				\
   guix/build/gnu-build-system.scm		\
+  guix/build/ftp.scm				\
   guix/build/http.scm				\
   guix/build/utils.scm				\
   guix/packages.scm				\
diff --git a/distro/base.scm b/distro/base.scm
index c0c51ff0bc..3790f48bfd 100644
--- a/distro/base.scm
+++ b/distro/base.scm
@@ -19,6 +19,7 @@
 (define-module (distro base)
   #:use-module (distro)
   #:use-module (guix packages)
+  #:use-module (guix ftp)
   #:use-module (guix http)
   #:use-module (guix build-system gnu)
   #:use-module (guix build-system trivial)
@@ -1138,9 +1139,9 @@ extensible.  It supports many SRFIs.")
     (name "libffi")
     (version "3.0.9")
     (source (origin
-             (method http-fetch)
-             (uri ;; FIXME: should be ftp://
-              (string-append "http://sourceware.org/pub/libffi/"
+             (method ftp-fetch)
+             (uri
+              (string-append "ftp://sourceware.org/pub/libffi/"
                              name "-" version ".tar.gz"))
              (sha256
               (base32
diff --git a/guix/build/ftp.scm b/guix/build/ftp.scm
new file mode 100644
index 0000000000..17486953c2
--- /dev/null
+++ b/guix/build/ftp.scm
@@ -0,0 +1,48 @@
+;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
+;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of Guix.
+;;;
+;;; 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
+;;; 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/>.
+
+(define-module (guix build ftp)
+  #:use-module (guix ftp-client)
+  #:use-module (guix build utils)
+  #:use-module (web uri)
+  #:export (ftp-fetch))
+
+;;; Commentary:
+;;;
+;;; Fetch data such as tarballs over FTP (builder-side code).
+;;;
+;;; Code:
+
+(define (ftp-fetch url file)
+  "Fetch data from URL and write it to FILE.  Return FILE on success."
+
+  (setvbuf (current-output-port) _IOLBF)
+  (format #t "starting FTP download of `~a' from `~a'...~%" file url)
+  (let* ((uri  (string->uri url))
+         (conn (ftp-open (uri-host uri)))
+         (in   (ftp-retr conn (basename (uri-path uri))
+                         (dirname (uri-path uri)))))
+    (call-with-output-file file
+      (lambda (out)
+        ;; TODO: Show a progress bar.
+        (dump-port in out)))
+
+    (ftp-close conn))
+  file)
+
+;;; ftp.scm ends here
diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm
new file mode 100644
index 0000000000..220419734f
--- /dev/null
+++ b/guix/ftp-client.scm
@@ -0,0 +1,224 @@
+;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
+;;; Copyright (C) 2010, 2011, 2012 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of Guix.
+;;;
+;;; 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
+;;; 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/>.
+
+(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
+
+            ftp-open
+            ftp-close
+            ftp-chdir
+            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 #\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 (ftp-open host)
+  (catch 'getaddrinfo-error
+    (lambda ()
+      (let* ((ai (car (getaddrinfo host "ftp")))
+             (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+                         (addrinfo:protocol ai))))
+        (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" "ludo@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 (key errcode)
+      (format (current-error-port) "failed to resolve `~a': ~a~%"
+              host (gai-strerror errcode))
+      #f)))
+
+(define (ftp-close conn)
+  (close (ftp-connection-socket conn)))
+
+(define (ftp-chdir conn dir)
+  (%ftp-command (string-append "CWD " dir) 250
+                (ftp-connection-socket conn)))
+
+(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
diff --git a/guix/ftp.scm b/guix/ftp.scm
new file mode 100644
index 0000000000..79bae6ece6
--- /dev/null
+++ b/guix/ftp.scm
@@ -0,0 +1,49 @@
+;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
+;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of Guix.
+;;;
+;;; 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
+;;; 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 <ftp://www.gnu.org/licenses/>.
+
+(define-module (guix ftp)
+  #:use-module (guix derivations)
+  #:use-module (guix utils)
+  #:export (ftp-fetch))
+
+;;; Commentary:
+;;;
+;;; Produce fixed-output derivations with data fetched over FTP.
+;;;
+;;; Code:
+
+(define* (ftp-fetch store url hash-algo hash
+                    #:optional name
+                    #:key (system (%current-system)))
+  "Return the path of a fixed-output derivation in STORE that fetches URL,
+which is expected to have hash HASH of type HASH-ALGO (a symbol).  By
+default, the file name is the base name of URL; optionally, NAME can specify
+a different file name."
+  (define builder
+    `(begin
+       (use-modules (guix build ftp))
+       (ftp-fetch ,url %output)))
+
+  (build-expression->derivation store (or name (basename url)) system
+                                builder '()
+                                #:hash-algo hash-algo
+                                #:hash hash
+                                #:modules '((guix ftp-client)
+                                            (guix build ftp)
+                                            (guix build utils))))
+;;; ftp.scm ends here