From bdc298ecee15283451d3aa20a849dd7bb22c8538 Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Wed, 2 Jun 2021 17:18:22 +0200 Subject: import: Add CHICKEN egg importer. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/egg.scm: New file. * guix/scripts/import/egg.scm: New file. * tests/egg.scm: New file. * Makefile.am (MODULES, SCM_TESTS): Register them. * po/guix/POTFILES.in: Likewise. * guix/scripts/import.scm (importers): Add egg importer. * doc/guix.texi (Invoking guix import, Invoking guix refresh): Document it. Signed-off-by: Ludovic Courtès --- guix/import/egg.scm | 352 ++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 4 +- guix/scripts/import/egg.scm | 107 ++++++++++++++ 3 files changed, 461 insertions(+), 2 deletions(-) create mode 100644 guix/import/egg.scm create mode 100644 guix/scripts/import/egg.scm (limited to 'guix') diff --git a/guix/import/egg.scm b/guix/import/egg.scm new file mode 100644 index 0000000000..26f8364732 --- /dev/null +++ b/guix/import/egg.scm @@ -0,0 +1,352 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen +;;; +;;; 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 . + +(define-module (guix import egg) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:use-module (gcrypt hash) + #:use-module (guix git) + #:use-module (guix i18n) + #:use-module (guix base32) + #:use-module (guix diagnostics) + #:use-module (guix memoization) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix build-system) + #:use-module (guix build-system chicken) + #:use-module (guix store) + #:use-module ((guix download) #:select (download-to-store url-fetch)) + #:use-module (guix import utils) + #:use-module ((guix licenses) #:prefix license:) + #:export (egg->guix-package + egg-recursive-import + %egg-updater + + ;; For tests. + guix-package->egg-name)) + +;;; Commentary: +;;; +;;; (guix import egg) provides package importer for CHICKEN eggs. See the +;;; official specification format for eggs +;;; . +;;; +;;; The following happens under the hood: +;;; +;;; * is a Git repository that contains +;;; the latest version of all CHICKEN eggs. We look clone this repository +;;; and retrieve the latest version number, and the PACKAGE.egg file, which +;;; contains a list of lists containing metadata about the egg. +;;; +;;; * All the eggs are stored as tarballs at +;;; , so we grab the tarball for +;;; the egg from there. +;;; +;;; * The rest of the package fields will be parsed from the PACKAGE.egg file. +;;; +;;; Todos: +;;; +;;; * Support for CHICKEN 4? +;;; +;;; * Some packages will specify a specific version of a depencency in the +;;; PACKAGE.egg file, how should we handle this? +;;; +;;; Code: + + +;;; +;;; Egg metadata fetcher and helper functions. +;;; + +(define package-name-prefix "chicken-") + +(define %eggs-url + (make-parameter "https://code.call-cc.org/egg-tarballs/5")) + +(define %eggs-home-page + (make-parameter "https://wiki.call-cc.org/egg")) + +(define (egg-source-url name version) + "Return the URL to the source tarball for version VERSION of the CHICKEN egg +NAME." + (string-append (%eggs-url) "/" name "/" name "-" version ".tar.gz")) + +(define (egg-name->guix-name name) + "Return the package name for CHICKEN egg NAME." + (string-append package-name-prefix name)) + +(define (eggs-repository) + "Update or fetch the latest version of the eggs repository and return the path +to the repository." + (let* ((url "git://code.call-cc.org/eggs-5-latest") + (directory commit _ (update-cached-checkout url))) + directory)) + +(define (egg-directory name) + "Return the directory containing the source code for the egg NAME." + (let ((eggs-directory (eggs-repository))) + (string-append eggs-directory "/" name))) + +(define (find-latest-version name) + "Get the latest version of the egg NAME." + (let ((directory (scandir (egg-directory name)))) + (if directory + (last directory) + #f))) + +(define* (egg-metadata name #:optional file) + "Return the package metadata file for the egg NAME, or if FILE is specified, +return the package metadata in FILE." + (call-with-input-file (or file + (string-append (egg-directory name) "/" + (find-latest-version name) + "/" name ".egg")) + read)) + +(define (guix-name->egg-name name) + "Return the CHICKEN egg name corresponding to the Guix package NAME." + (if (string-prefix? package-name-prefix name) + (string-drop name (string-length package-name-prefix)) + name)) + +(define (guix-package->egg-name package) + "Return the CHICKEN egg name of the Guix CHICKEN PACKAGE." + (or (assq-ref (package-properties package) 'upstream-name) + (guix-name->egg-name (package-name package)))) + +(define (egg-package? package) + "Check if PACKAGE is an CHICKEN egg package." + (and (eq? (package-build-system package) chicken-build-system) + (string-prefix? package-name-prefix (package-name package)))) + +(define string->license + ;; Doesn't seem to use a specific format. + ;; + (match-lambda + ("GPL-2" 'license:gpl2) + ("GPL-2+" 'license:gpl2+) + ("GPL-3" 'license:gpl3) + ("GPL-3+" 'license:gpl3+) + ("GPL" 'license:gpl?) + ("AGPL-3" 'license:agpl3) + ("AGPL" 'license:agpl?) + ("LGPL-2.0" 'license:lgpl2.0) + ("LGPL-2.0+" 'license:lgpl2.0+) + ("LGPL-2.1" 'license:lgpl2.1) + ("LGPL-2.1+" 'license:lgpl2.1+) + ("LGPL-3" 'license:lgpl3) + ("LGPL-3" 'license:lgpl3+) + ("LGPL" 'license:lgpl?) + ("BSD-1-Clause" 'license:bsd-1) + ("BSD-2-Clause" 'license:bsd-2) + ("BSD-3-Clause" 'license:bsd-3) + ("BSD" 'license:bsd?) + ("MIT" 'license:expat) + ("ISC" 'license:isc) + ("Artistic-2" 'license:artistic2.0) + ("Apache-2.0" 'license:asl2.0) + ("Public Domain" 'license:public-domain) + ((x) (string->license x)) + ((lst ...) `(list ,@(map string->license lst))) + (_ #f))) + + +;;; +;;; Egg importer. +;;; + +(define* (egg->guix-package name #:key (file #f) (source #f)) + "Import CHICKEN egg NAME from and return a record type for the +egg, or #f on failure. FILE is the filepath to the NAME.egg file. SOURCE is +the a ``file-like'' object containing the source code corresonding to the egg. +If SOURCE is not specified, the tarball for the egg will be downloaded. + +Specifying the SOURCE argument is mainly useful for developing a CHICKEN egg +locally. Note that if FILE and SOURCE are specified, recursive import will +not work." + (define egg-content (if file + (egg-metadata name file) + (egg-metadata name))) + (if (not egg-content) + (values #f '()) ; egg doesn't exist + (let* ((version* (or (assoc-ref egg-content 'version) + (find-latest-version name))) + (version (if (list? version*) (first version*) version*)) + (source-url (if source #f (egg-source-url name version))) + (tarball (if source + #f + (with-store store + (download-to-store store source-url))))) + + (define egg-home-page + (string-append (%eggs-home-page) "/" name)) + + (define egg-synopsis + (match (assoc-ref egg-content 'synopsis) + ((synopsis) synopsis) + (_ #f))) + + (define egg-licenses + (let ((licenses* + (match (assoc-ref egg-content 'license) + ((license) + (map string->license (string-split license #\/))) + (#f + '())))) + (match licenses* + ((license) license) + ((license1 license2 ...) `(list ,@licenses*))))) + + (define (maybe-symbol->string sym) + (if (symbol? sym) (symbol->string sym) sym)) + + (define (prettify-system-dependency name) + ;; System dependencies sometimes have spaces and/or upper case + ;; letters in them. + ;; + ;; There will probably still be some weird edge cases. + (string-map (lambda (char) + (case char + ((#\space) #\-) + (else char))) + (maybe-symbol->string name))) + + (define* (egg-parse-dependency name #:key (system? #f)) + (define extract-name + (match-lambda + ((name version) name) + (name name))) + + (define (prettify-name name) + (if system? + (prettify-system-dependency name) + (maybe-symbol->string name))) + + (let ((name (prettify-name (extract-name name)))) + ;; Dependencies are sometimes specified as symbols and sometimes + ;; as strings + (list (string-append (if system? "" package-name-prefix) + name) + (list 'unquote + (string->symbol (string-append + (if system? "" package-name-prefix) + name)))))) + + (define egg-propagated-inputs + (let ((dependencies (assoc-ref egg-content 'dependencies))) + (if (list? dependencies) + (map egg-parse-dependency + dependencies) + '()))) + + ;; TODO: Or should these be propagated? + (define egg-inputs + (let ((dependencies (assoc-ref egg-content 'foreign-dependencies))) + (if (list? dependencies) + (map (lambda (name) + (egg-parse-dependency name #:system? #t)) + dependencies) + '()))) + + (define egg-native-inputs + (let* ((test-dependencies (or (assoc-ref egg-content + 'test-dependencies) + '())) + (build-dependencies (or (assoc-ref egg-content + 'build-dependencies) + '())) + (test+build-dependencies (append test-dependencies + build-dependencies))) + (match test+build-dependencies + ((_ _ ...) (map egg-parse-dependency + test+build-dependencies)) + (() '())))) + + ;; Copied from (guix import hackage). + (define (maybe-inputs input-type inputs) + (match inputs + (() + '()) + ((inputs ...) + (list (list input-type + (list 'quasiquote inputs)))))) + + (values + `(package + (name ,(egg-name->guix-name name)) + (version ,version) + (source + ,(if source + source + `(origin + (method url-fetch) + (uri ,source-url) + (sha256 + (base32 ,(if tarball + (bytevector->nix-base32-string + (file-sha256 tarball)) + "failed to download tar archive")))))) + (build-system chicken-build-system) + (arguments ,(list 'quasiquote (list #:egg-name name))) + ,@(maybe-inputs 'native-inputs egg-native-inputs) + ,@(maybe-inputs 'inputs egg-inputs) + ,@(maybe-inputs 'propagated-inputs egg-propagated-inputs) + (home-page ,egg-home-page) + (synopsis ,egg-synopsis) + (description #f) + (license ,egg-licenses)) + (filter (lambda (name) + (not (member name '("srfi-4")))) + (map (compose guix-name->egg-name first) + (append egg-propagated-inputs + egg-native-inputs))))))) + +(define egg->guix-package/m ;memoized variant + (memoize egg->guix-package)) + +(define (egg-recursive-import package-name) + (recursive-import package-name + #:repo->guix-package (lambda* (name #:key version repo) + (egg->guix-package/m name)) + #:guix-name egg-name->guix-name)) + + +;;; +;;; Updater. +;;; + +(define (latest-release package) + "Return an @code{} for the latest release of PACKAGE." + (let* ((egg-name (guix-package->egg-name package)) + (version (find-latest-version egg-name)) + (source-url (egg-source-url egg-name version))) + (upstream-source + (package (package-name package)) + (version version) + (urls (list source-url))))) + +(define %egg-updater + (upstream-updater + (name 'egg) + (description "Updater for CHICKEN egg packages") + (pred egg-package?) + (latest latest-release))) + +;;; egg.scm ends here diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index bbd9a3b190..f53d1ac1f4 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -76,8 +76,8 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "elpa" "gem" - "go" "cran" "crate" "texlive" "json" "opam")) +(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" + "gem" "go" "cran" "crate" "texlive" "json" "opam")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/egg.scm b/guix/scripts/import/egg.scm new file mode 100644 index 0000000000..7dbd6fcd5a --- /dev/null +++ b/guix/scripts/import/egg.scm @@ -0,0 +1,107 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen +;;; +;;; 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 . + +(define-module (guix scripts import egg) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import egg) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-egg)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import egg PACKAGE-NAME +Import and convert the egg package for PACKAGE-NAME.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import egg"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-egg . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (repo (and=> (assoc-ref opts 'repo) string->symbol)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (egg-recursive-import package-name)) + ;; Single import + (let ((sexp (egg->guix-package package-name))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) -- cgit v1.2.3