From 2ad1f71d72d72ca742005c4244e9a997411473f0 Mon Sep 17 00:00:00 2001
From: Carlo Zancanaro <carlo@zancanaro.id.au>
Date: Sat, 28 Dec 2019 12:34:33 +1100
Subject: [PATCH] import: Add importer for MELPA packages.
* guix/import/melpa.scm: New file.
* guix/scripts/import/melpa.scm: New file.
* guix/scripts/import.scm (importers): Add melpa importer.
* doc/guix.texi: Add melpa importer to table.
* Makefile.am (MODULES): Add files.
---
Makefile.am | 2 +
doc/guix.texi | 10 ++
guix/import/melpa.scm | 216 ++++++++++++++++++++++++++++++++++
guix/scripts/import.scm | 2 +-
guix/scripts/import/melpa.scm | 99 ++++++++++++++++
5 files changed, 328 insertions(+), 1 deletion(-)
create mode 100644 guix/import/melpa.scm
create mode 100644 guix/scripts/import/melpa.scm
@@ -217,6 +217,7 @@ MODULES = \
guix/import/cran.scm \
guix/import/crate.scm \
guix/import/elpa.scm \
+ guix/import/melpa.scm \
guix/import/gem.scm \
guix/import/github.scm \
guix/import/gnome.scm \
@@ -262,6 +263,7 @@ MODULES = \
guix/scripts/import/crate.scm \
guix/scripts/import/cran.scm \
guix/scripts/import/elpa.scm \
+ guix/scripts/import/melpa.scm \
guix/scripts/import/gem.scm \
guix/scripts/import/gnu.scm \
guix/scripts/import/hackage.scm \
@@ -9215,6 +9215,16 @@ and generate package expressions for all those packages that are not yet
in Guix.
@end table
+@item melpa
+@cindex melpa
+Import a package recipe from @uref{https://melpa.org/packages, MELPA}.
+Unlike the ELPA importer, above, the MELPA importer does not use source
+archives, but builds its package from the upstream source.
+
+@example
+guix import melpa org-mime
+@end example
+
@item crate
@cindex crate
Import metadata from the crates.io Rust package repository
new file mode 100644
@@ -0,0 +1,216 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2019 Carlo Zancanaro <carlo@zancanaro.id.au>
+;;;
+;;; 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 melpa)
+ #:use-module (gcrypt hash)
+ #:use-module (guix base32)
+ #:use-module (guix git)
+ #:use-module (guix http-client)
+ #:use-module (guix import utils)
+ #:use-module (guix serialization)
+ #:use-module (guix store)
+ #:use-module (ice-9 control)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (web uri)
+ #:export (melpa->guix-package))
+
+(define emacs-standard-library?
+ (let ((libs '("emacs" "cl-lib")))
+ (lambda (lib)
+ "Return true if LIB is part of Emacs itself. The check is not
+exhaustive and only attempts to recognize a subset of packages which in the
+past were distributed separately from Emacs."
+ (member lib libs))))
+
+(define* (download-git-repository url ref)
+ (with-store store
+ (latest-repository-commit store url #:ref ref)))
+
+(define (package-name->recipe-url package-name)
+ (string-append "https://raw.githubusercontent.com/melpa/melpa/master/recipes/"
+ package-name))
+
+(define (package-name->recipe package-name)
+ (define (data->recipe data)
+ (match data
+ (() '())
+ ((key value . tail)
+ (cons (cons key value) (data->recipe tail)))))
+
+ (let* ((port (http-fetch/cached (string->uri (package-name->recipe-url package-name))
+ #:ttl (* 6 3600)))
+ (previous-keyword-mode (match (member 'keywords (read-options))
+ ((_ value . _) value)))
+ (data (begin
+ (read-set! keywords 'prefix)
+ (read port))))
+ (read-set! keywords previous-keyword-mode)
+ (close-port port)
+ (data->recipe (cons #:name data))))
+
+(define (github-repo->url repo)
+ (string-append "https://github.com/" repo ".git"))
+
+(define (gitlab-repo->url repo)
+ (string-append "https://gitlab.com/" repo ".git"))
+
+;; XXX adapted from (guix scripts hash)
+(define (file-hash file select? recursive?)
+ ;; Compute the hash of FILE.
+ (if recursive?
+ (let-values (((port get-hash) (open-sha256-port)))
+ (write-file file port #:select? select?)
+ (force-output port)
+ (get-hash))
+ (call-with-input-file file port-sha256)))
+
+;; XXX taken from (guix scripts hash)
+(define (vcs-file? file stat)
+ (case (stat:type stat)
+ ((directory)
+ (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+ ((regular)
+ ;; Git sub-modules have a '.git' file that is a regular text file.
+ (string=? (basename file) ".git"))
+ (else
+ #f)))
+
+(define (emacs-requires->inputs requires)
+ (define (require-symbol->input-string require)
+ (let ((require-string (symbol->string (if (pair? require)
+ (car require)
+ require))))
+ (if (emacs-standard-library? require-string)
+ #f
+ (string-append "emacs-" require-string))))
+
+ (package-names->package-inputs
+ (filter identity (map require-symbol->input-string requires))))
+
+;; This is a regular expression that will extract the package requirements
+;; from a line of elisp. See "(elisp) Library Headers" for more details about
+;; this header.
+(define package-depends-regexp
+ (make-regexp "\\s*;+\\s**package-requires:(.*)" regexp/icase))
+
+(define (find-package-inputs directory)
+ (define (for-each-line f file)
+ (call-with-input-file file
+ (lambda (port)
+ (let loop ()
+ (let ((line (read-line port 'concat)))
+ (unless (eof-object? line)
+ (f line)
+ (loop)))))))
+
+ (emacs-requires->inputs
+ (call/ec (lambda (return)
+ (for-each
+ (lambda (filename)
+ (for-each-line
+ (lambda (line)
+ (let ((match-data (regexp-exec package-depends-regexp line)))
+ (when match-data
+ (return (with-input-from-string (match:substring match-data 1)
+ read)))))
+ (string-append directory "/" filename)))
+ (scandir directory (cut string-suffix-ci? ".el" <>)))
+ (return '())))))
+
+
+(define (git-repository->package recipe url)
+ (define ref
+ (cond
+ ((assoc-ref recipe #:branch)
+ => (lambda (branch) (cons 'branch branch)))
+ ((assoc-ref recipe #:commit)
+ => (lambda (commit) (cons 'commit commit)))
+ (else
+ '(branch . "master"))))
+
+ (define (maybe-inputs input-type inputs)
+ (if (null? inputs)
+ (list)
+ (list (list input-type (list 'quasiquote inputs)))))
+
+ (define (maybe-arguments files)
+ (define (glob->regexp glob)
+ (string-append
+ "^"
+ (regexp-substitute/global #f "\\*\\*?" glob
+ 'pre
+ (lambda (m)
+ (if (string= (match:substring m 0) "**")
+ ".*"
+ "[^/]+"))
+ 'post)
+ "$"))
+
+ (if files
+ `((arguments '(#:include ',(map glob->regexp (remove pair? files))
+ #:exclude ',(map glob->regexp (apply append
+ (map (match-lambda
+ ((#:exclude . values)
+ values)
+ (_ '()))
+ files))))))
+ '()))
+
+ (let-values (((directory commit) (download-git-repository url ref)))
+ (let ((inputs (find-package-inputs directory)))
+ `(package
+ (name ,(string-append "emacs-" (symbol->string (assoc-ref recipe #:name))))
+ (version , (strftime "%Y%m%d" (gmtime (current-time))))
+ (source (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url ,url)
+ (commit ,commit)))
+ (sha256
+ (base32
+ ,(bytevector->nix-base32-string
+ (file-hash directory (negate vcs-file?) #t))))))
+ (build-system emacs-build-system)
+ ,@(maybe-inputs 'propagated-inputs
+ (find-package-inputs directory))
+ ,@(maybe-arguments (assoc-ref recipe #:files))
+ (home-page #f)
+ (description #f)
+ (synopsis #f)
+ (license #f)))))
+
+(define (melpa->guix-package package-name)
+ "Construct a Guix package based on the MELPA recipe for PACKAGE-NAME."
+ (let ((recipe (package-name->recipe package-name)))
+ (match (assoc-ref recipe #:fetcher)
+ ('github (git-repository->package recipe
+ (github-repo->url (assoc-ref recipe #:repo))))
+ ('gitlab (git-repository->package recipe
+ (gitlab-repo->url (assoc-ref recipe #:repo))))
+ ('git (git-repository->package recipe
+ (assoc-ref recipe #:url)))
+ (_ (leave (G_ "Only github, gitlab, and git repositories are currently supported"))))))
@@ -76,7 +76,7 @@ rather than \\n."
;;;
(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem"
- "cran" "crate" "texlive" "json" "opam"))
+ "cran" "crate" "texlive" "json" "opam" "melpa"))
(define (resolve-importer name)
(let ((module (resolve-interface
new file mode 100644
@@ -0,0 +1,99 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
+;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2019 Carlo Zancanaro <carlo@zancanaro.id.au>
+;;;
+;;; 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 scripts import melpa)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix scripts)
+ #:use-module (guix import melpa)
+ #:use-module (guix import utils)
+ #: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-melpa))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ '((repo . gnu)))
+
+(define (show-help)
+ (display (G_ "Usage: guix import melpa PACKAGE-NAME
+Import the latest package named PACKAGE-NAME from the MELPA repository recipes.\n"))
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (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 melpa")))
+ (option '(#\r "recursive") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'recursive #t result)))
+ %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-melpa . 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))
+ (args (filter-map (match-lambda
+ (('argument . value)
+ value)
+ (_ #f))
+ (reverse opts))))
+ (match args
+ ((package-name)
+ (let ((sexp (melpa->guix-package package-name)))
+ (unless sexp
+ (leave (G_ "failed to download package '~a'~%") package-name))
+ sexp))
+ (()
+ (leave (G_ "too few arguments~%")))
+ ((many ...)
+ (leave (G_ "too many arguments~%"))))))
+
+;;; melpa.scm ends here
--
2.24.1