diff options
| -rw-r--r-- | Makefile.am | 3 | ||||
| -rw-r--r-- | distro/base.scm | 7 | ||||
| -rw-r--r-- | guix/build/ftp.scm | 48 | ||||
| -rw-r--r-- | guix/ftp-client.scm | 224 | ||||
| -rw-r--r-- | guix/ftp.scm | 49 |
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 |