ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Add (guix ftp) and companion modules.

Browse source 
* 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'.
This commit is contained in:
Ludovic Courtès 2012-09-12 23:47:49 +02:00
parent fb585745ad
commit 457dd86d66
5 changed files with 328 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile.am
View file

@ -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 \

7
distro/base.scm
View file

@ -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 @@ (define out (assoc-ref outputs "out"))
(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

48
guix/build/ftp.scm Normal file
View file

@ -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

224
guix/ftp-client.scm Normal file
View file

@ -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

49
guix/ftp.scm Normal file
View file

@ -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