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

diff --git a/Makefile.am b/Makefile.am
index 6106250b37..0fdd829f3e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -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		\
diff --git a/doc/guix.texi b/doc/guix.texi
index efc59c1aaf..9e75e619ff 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -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
diff --git a/guix/import/melpa.scm b/guix/import/melpa.scm
new file mode 100644
index 0000000000..cd22018589
--- /dev/null
+++ b/guix/import/melpa.scm
@@ -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"))))))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index c6cc93fad8..1c5fc68776 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -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
diff --git a/guix/scripts/import/melpa.scm b/guix/scripts/import/melpa.scm
new file mode 100644
index 0000000000..5e298b87b2
--- /dev/null
+++ b/guix/scripts/import/melpa.scm
@@ -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

