From patchwork Wed Mar 18 02:54:52 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Carlo Zancanaro X-Patchwork-Id: 20739 X-Patchwork-Delegate: mail@cbaines.net Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 2CBEC27BBE4; Wed, 18 Mar 2020 02:56:12 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 39FC627BBEA for ; Wed, 18 Mar 2020 02:56:11 +0000 (GMT) Received: from localhost ([::1]:44556 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jEOsM-0005CA-Oy for patchwork@mira.cbaines.net; Tue, 17 Mar 2020 22:56:10 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:52640) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jEOsG-0005C3-GS for guix-patches@gnu.org; Tue, 17 Mar 2020 22:56:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1jEOsE-0000dp-GT for guix-patches@gnu.org; Tue, 17 Mar 2020 22:56:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:33742) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1jEOsE-0000aZ-BO for guix-patches@gnu.org; Tue, 17 Mar 2020 22:56:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jEOsE-000414-9A for guix-patches@gnu.org; Tue, 17 Mar 2020 22:56:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#38769] [PATCH] import: Add importer for MELPA packages. Resent-From: Carlo Zancanaro Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Wed, 18 Mar 2020 02:56:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 38769 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: Brett Gilio Cc: 38769@debbugs.gnu.org Received: via spool by 38769-submit@debbugs.gnu.org id=B38769.158450010215342 (code B ref 38769); Wed, 18 Mar 2020 02:56:02 +0000 Received: (at 38769) by debbugs.gnu.org; 18 Mar 2020 02:55:02 +0000 Received: from localhost ([127.0.0.1]:39715 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jEOrF-0003zB-JE for submit@debbugs.gnu.org; Tue, 17 Mar 2020 22:55:02 -0400 Received: from zancanaro.com.au ([45.76.117.151]:48156) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jEOrD-0003yv-HC for 38769@debbugs.gnu.org; Tue, 17 Mar 2020 22:55:00 -0400 Received: by zancanaro.com.au (Postfix, from userid 116) id 4FD2D2D664; Wed, 18 Mar 2020 02:54:57 +0000 (UTC) Received: from jolteon (210-1-202-160-cpe.spintel.net.au [210.1.202.160]) by zancanaro.com.au (Postfix) with ESMTPSA id 51A622D573; Wed, 18 Mar 2020 02:54:55 +0000 (UTC) References: <87v9q1jjlf.fsf@zancanaro.id.au> <87r20bqco9.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.3 From: Carlo Zancanaro In-reply-to: <87r20bqco9.fsf@gnu.org> Date: Wed, 18 Mar 2020 13:54:52 +1100 Message-ID: <874kum9xtv.fsf@zancanaro.id.au> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches Hey Brett! It's been a while, but I've finally found time to revisit this patch. On Wed, Jan 08 2020, Brett Gilio wrote: > ... we /should/ combine this with the ELPA importer in its > current tradition: `guix import elpa -a melpa`. That seems > preferable to me, as it would avoid the need to deprecate a > command flag in our UX. I've done this. Carlo From eee82d9668410c3b71884082fa770417f6b53921 Mon Sep 17 00:00:00 2001 From: Carlo Zancanaro Date: Wed, 18 Mar 2020 13:38:50 +1100 Subject: [PATCH] import: elpa: Fetch MELPA packages with a stable git-reference. * guix/import/elpa.scm (default-files-spec): New variable. (download-git-repository, package-name->melpa-recipe, file-hash, vcs-file?, git-repository->origin, melpa-recipe->origin, melpa-recipe->maybe-arguments): New procedures. (elpa-package->sexp): Add optional repo argument, and use it to determine whether to attempt to construct a source using the MELPA recipe. (elpa->guix-package): Pass repo to elpa-package->sexp. --- guix/import/elpa.scm | 189 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 166 insertions(+), 23 deletions(-) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 2d4487dba0..2483b57385 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -21,6 +21,7 @@ (define-module (guix import elpa) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -30,6 +31,8 @@ #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) #:use-module (guix http-client) + #:use-module (guix git) + #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix store) #:use-module (guix ui) #:use-module (gcrypt hash) @@ -195,10 +198,143 @@ include VERSION." url))) (_ #f)))) -(define* (elpa-package->sexp pkg #:optional license) +(define* (download-git-repository url ref) + "Fetch the given REF from the Git repository at URL." + (with-store store + (latest-repository-commit store url #:ref ref))) + +(define (package-name->melpa-recipe package-name) + "Fetch the MELPA recipe for PACKAGE-NAME, represented as an alist from +keywords to values." + (define recipe-url + (string-append "https://raw.githubusercontent.com/melpa/melpa/master/recipes/" + 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 recipe-url) + #:ttl (* 6 3600))) + (data (read port))) + (close-port port) + (data->recipe (cons ':name data)))) + +;; 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 (git-repository->origin recipe url) + "Fetch origin details from the Git repository at URL for the provided MELPA +RECIPE." + (define ref + (cond + ((assoc-ref recipe #:branch) + => (lambda (branch) (cons 'branch branch))) + ((assoc-ref recipe #:commit) + => (lambda (commit) (cons 'commit commit))) + (else + '(branch . "master")))) + + (let-values (((directory commit) (download-git-repository url ref))) + `(origin + (method git-fetch) + (uri (git-reference + (url ,url) + (commit ,commit))) + (sha256 + (base32 + ,(bytevector->nix-base32-string + (file-hash directory (negate vcs-file?) #t))))))) + +(define* (melpa-recipe->origin recipe) + "Fetch origin details from the MELPA recipe and associated repository for +the package named PACKAGE-NAME." + (define (github-repo->url repo) + (string-append "https://github.com/" repo ".git")) + (define (gitlab-repo->url repo) + (string-append "https://gitlab.com/" repo ".git")) + + (match (assq-ref recipe ':fetcher) + ('github (git-repository->origin recipe (github-repo->url (assq-ref recipe ':repo)))) + ('gitlab (git-repository->origin recipe (gitlab-repo->url (assq-ref recipe ':repo)))) + ('git (git-repository->origin recipe (assq-ref recipe ':url))) + (#f #f) ; if we're not using melpa then this stops us printing a warning + (_ (warning (G_ "Unsupported MELPA fetcher: ~a, falling back to unstable MELPA source.~%") + (assq-ref recipe ':fetcher)) + #f))) + +(define default-files-spec + ;; This contains more than just the things contained in %default-include and + ;; %default-exclude, presumably because this includes source files (*.in, + ;; *.texi, etc.) which have already been processed for releases. + ;; + ;; Taken from: + ;; https://github.com/melpa/melpa/blob/e8dc709d0ab2b4a68c59315f42858bcb86095f11/package-build/package-build.el#L580-L585 + '("*.el" "*.el.in" "dir" + "*.info" "*.texi" "*.texinfo" + "doc/dir" "doc/*.info" "doc/*.texi" "doc/*.texinfo" + (:exclude ".dir-locals.el" "test.el" "tests.el" "*-test.el" "*-tests.el"))) + +(define* (melpa-recipe->maybe-arguments melpa-recipe) + "Extract arguments for the build system from MELPA-RECIPE." + (define (glob->regexp glob) + (string-append + "^" + (regexp-substitute/global #f "\\*\\*?" glob + 'pre + (lambda (m) + (if (string= (match:substring m 0) "**") + ".*" + "[^/]+")) + 'post) + "$")) + + (let ((files (assq-ref melpa-recipe ':files))) + (if files + (let* ((with-default (apply append (map (lambda (entry) + (if (eq? ':defaults entry) + default-files-spec + (list entry))) + files))) + (inclusions (remove pair? with-default)) + (exclusions (apply append (map (match-lambda + ((':exclude . values) + values) + (_ '())) + with-default)))) + `((arguments '(#:include ',(map glob->regexp inclusions) + #:exclude ',(map glob->regexp exclusions))))) + '()))) + +(define* (elpa-package->sexp pkg #:optional license repo) "Return the `package' S-expression for the Emacs package PKG, a record of type ''." + (define melpa-recipe + (if (eq? repo 'melpa) + (package-name->melpa-recipe (elpa-package-name pkg)) + #f)) + (define name (elpa-package-name pkg)) (define version (elpa-package-version pkg)) @@ -223,27 +359,34 @@ type ''." (list (list input-type (list 'quasiquote inputs)))))) - (let ((tarball (with-store store - (download-to-store store source-url)))) - (values - `(package - (name ,(elpa-name->package-name name)) - (version ,version) - (source (origin - (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) - (sha256 - (base32 - ,(if tarball - (bytevector->nix-base32-string (file-sha256 tarball)) - "failed to download package"))))) - (build-system emacs-build-system) - ,@(maybe-inputs 'propagated-inputs dependencies) - (home-page ,(elpa-package-home-page pkg)) - (synopsis ,(elpa-package-synopsis pkg)) - (description ,(elpa-package-description pkg)) - (license ,license)) - dependencies-names))) + (define melpa-source + (melpa-recipe->origin melpa-recipe)) + + (values + `(package + (name ,(elpa-name->package-name name)) + (version ,version) + (source ,(or melpa-source + (let ((tarball (with-store store + (download-to-store store source-url)))) + `(origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(if tarball + (bytevector->nix-base32-string (file-sha256 tarball)) + "failed to download package"))))))) + (build-system emacs-build-system) + ,@(maybe-inputs 'propagated-inputs dependencies) + ,@(if melpa-source + (melpa-recipe->maybe-arguments melpa-recipe) + '()) + (home-page ,(elpa-package-home-page pkg)) + (synopsis ,(elpa-package-synopsis pkg)) + (description ,(elpa-package-description pkg)) + (license ,license)) + dependencies-names)) (define* (elpa->guix-package name #:optional (repo 'gnu)) "Fetch the package NAME from REPO and produce a Guix package S-expression." @@ -253,7 +396,7 @@ type ''." ;; ELPA is known to contain only GPLv3+ code. Other repos may contain ;; code under other license but there's no license metadata. (let ((license (and (memq repo '(gnu gnu/http)) 'license:gpl3+))) - (elpa-package->sexp package license))))) + (elpa-package->sexp package license repo))))) ;;; -- 2.25.1