summaryrefslogtreecommitdiff
path: root/guix/import
diff options
context:
space:
mode:
Diffstat (limited to 'guix/import')
-rw-r--r--guix/import/egg.scm352
1 files changed, 352 insertions, 0 deletions
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 <public@yoctocell.xyz>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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
+;;; <https://wiki.call-cc.org/man/5/Egg%20specification%20format>.
+;;;
+;;; The following happens under the hood:
+;;;
+;;; * <git://code.call-cc.org/eggs-5-latest> 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
+;;; <https://code.call-cc.org/egg-tarballs/5>, 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.
+ ;; <https://wiki.call-cc.org/eggs-licensing>
+ (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 <package> 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{<upstream-source>} 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