From patchwork Thu Nov 2 15:16:55 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Nicolas Graves X-Patchwork-Id: 55841 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 9FDC327BBE9; Thu, 2 Nov 2023 15:18:53 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id DFC4027BBE2 for ; Thu, 2 Nov 2023 15:18:50 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1qyZSs-000073-D8; Thu, 02 Nov 2023 11:18:34 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1qyZSo-00005v-Kj for guix-patches@gnu.org; Thu, 02 Nov 2023 11:18:30 -0400 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1qyZSo-0003qC-2w for guix-patches@gnu.org; Thu, 02 Nov 2023 11:18:30 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1qyZTN-0006cL-1a for guix-patches@gnu.org; Thu, 02 Nov 2023 11:19:05 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#42338] [PATCH v5 8/9] guix: import: composer: Full rewrite composer-fetch. Resent-From: Nicolas Graves Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 02 Nov 2023 15:19:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 42338 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 42338@debbugs.gnu.org Cc: ngraves@ngraves.fr Received: via spool by 42338-submit@debbugs.gnu.org id=B42338.169893830525320 (code B ref 42338); Thu, 02 Nov 2023 15:19:04 +0000 Received: (at 42338) by debbugs.gnu.org; 2 Nov 2023 15:18:25 +0000 Received: from localhost ([127.0.0.1]:55790 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qyZSi-0006aE-Tt for submit@debbugs.gnu.org; Thu, 02 Nov 2023 11:18:25 -0400 Received: from 7.mo575.mail-out.ovh.net ([46.105.63.230]:35809) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qyZSe-0006ZG-6W for 42338@debbugs.gnu.org; Thu, 02 Nov 2023 11:18:21 -0400 Received: from director8.ghost.mail-out.ovh.net (unknown [10.109.143.79]) by mo575.mail-out.ovh.net (Postfix) with ESMTP id 21FDA28F49 for <42338@debbugs.gnu.org>; Thu, 2 Nov 2023 15:17:44 +0000 (UTC) Received: from ghost-submission-6684bf9d7b-vt5f5 (unknown [10.110.103.93]) by director8.ghost.mail-out.ovh.net (Postfix) with ESMTPS id B5C3A1FEB4; Thu, 2 Nov 2023 15:17:43 +0000 (UTC) Received: from ngraves.fr ([37.59.142.99]) by ghost-submission-6684bf9d7b-vt5f5 with ESMTPSA id x1lWKZe9Q2Vq5gAA5SnFsg (envelope-from ); Thu, 02 Nov 2023 15:17:43 +0000 Authentication-Results: garm.ovh; auth=pass (GARM-99G003d815ace5-ccaf-45bc-aa7d-6b6576e44ec2, 1761E107A7246F2314AE904A186E6A889A3776EC) smtp.auth=ngraves@ngraves.fr X-OVh-ClientIp: 87.88.157.103 Date: Thu, 2 Nov 2023 16:16:55 +0100 Message-ID: <20231102151725.31362-9-ngraves@ngraves.fr> X-Mailer: git-send-email 2.41.0 In-Reply-To: <20231102151725.31362-1-ngraves@ngraves.fr> References: <20231102151725.31362-1-ngraves@ngraves.fr> MIME-Version: 1.0 X-Ovh-Tracer-Id: 13661669471634907874 X-VR-SPAMSTATE: OK X-VR-SPAMSCORE: 0 X-VR-SPAMCAUSE: gggruggvucftvghtrhhoucdtuddrgedvkedruddtiedgjeehucetufdoteggodetrfdotffvucfrrhhofhhilhgvmecuqfggjfdpvefjgfevmfevgfenuceurghilhhouhhtmecuhedttdenucenucfjughrpefhvfevufffkffojghfggfgsedtkeertdertddtnecuhfhrohhmpefpihgtohhlrghsucfirhgrvhgvshcuoehnghhrrghvvghssehnghhrrghvvghsrdhfrheqnecuggftrfgrthhtvghrnhepgffgfeevhfegueetgeektdeiueejieelteffudeugfefffelffegveeffeetffdtnecuffhomhgrihhnpehprggtkhgrghhishhtrdhorhhgnecukfhppeduvdejrddtrddtrddupdekjedrkeekrdduheejrddutdefpdefjedrheelrddugedvrdelleenucevlhhushhtvghrufhiiigvpedunecurfgrrhgrmhepihhnvghtpeduvdejrddtrddtrddupdhmrghilhhfrhhomhepoehnghhrrghvvghssehnghhrrghvvghsrdhfrheqpdhnsggprhgtphhtthhopedupdhrtghpthhtohepgedvfeefkeesuggvsggsuhhgshdrghhnuhdrohhrghdpoffvtefjohhsthepmhhoheejhedpmhhouggvpehsmhhtphhouhht X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Reply-to: Nicolas Graves X-ACL-Warn: , Nicolas Graves via Guix-patches X-Patchwork-Original-From: Nicolas Graves via Guix-patches via From: Nicolas Graves Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches Change-Id: I1c01c242cefe0bc4cfc9bd9a5717d10a61dd575e --- guix/import/composer.scm | 154 +++++++++++++++++++-------------------- 1 file changed, 77 insertions(+), 77 deletions(-) diff --git a/guix/import/composer.scm b/guix/import/composer.scm index 89c8ea9113..2cc8861bdd 100644 --- a/guix/import/composer.scm +++ b/guix/import/composer.scm @@ -19,7 +19,7 @@ (define-module (guix import composer) #:use-module (ice-9 match) #:use-module (json) - #:use-module (gcrypt hash) + #:use-module (guix hash) #:use-module (guix base32) #:use-module (guix build git) #:use-module (guix build utils) @@ -44,27 +44,6 @@ (define-module (guix import composer) (define %composer-base-url (make-parameter "https://repo.packagist.org")) -;; 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 (fix-version version) "Return a fixed version from a version string. For instance, v10.1 -> 10.1" (cond @@ -114,22 +93,36 @@ (define-json-mapping make-composer-package composer-package? (car l) `(list ,@l)))))) -(define* (composer-fetch name #:optional version) - "Return an alist representation of the Composer metadata for the package NAME, -or #f on failure." - (let ((package (json-fetch - (string-append (%composer-base-url) "/p/" name ".json")))) - (if package - (let* ((packages (assoc-ref package "packages")) - (package (or (assoc-ref packages name) package)) - (versions (filter - (lambda (version) - (and (not (string-contains version "dev")) - (not (string-contains version "beta")))) - (map car package))) - (version (or (if (null? version) #f version) - (latest-version versions)))) - (assoc-ref package version)) +(define (valid-version? v) + (let ((d (string-downcase v))) + (and (not (string-contains d "dev")) + (not (string-contains d "beta")) + (not (string-contains d "rc"))))) + +(define* (composer-fetch name #:key (version #f)) + "Return a composer-package representation of the Composer metadata for the +package NAME with optional VERSION, or #f on failure." + (let* ((url (string-append (%composer-base-url) "/p/" name ".json")) + (packages (and=> (json-fetch url) + (lambda (pkg) + (let ((pkgs (assoc-ref pkg "packages"))) + (or (assoc-ref pkgs name) pkg)))))) + (if packages + (json->composer-package + (if version + (assoc-ref packages version) + (cdr + (reduce + (lambda (new cur-max) + (match new + (((? valid-version? version) . tail) + (if (version>? (fix-version version) + (fix-version (car cur-max))) + (cons* version tail) + cur-max)) + (_ cur-max))) + (cons* "0.0.0" #f) + packages)))) #f))) (define (php-package-name name) @@ -158,47 +151,55 @@ (define (make-php-sexp composer-package) (composer-source-reference source) temp)) (url-fetch (composer-source-url source) temp)) - `(package - (name ,(composer-package-name composer-package)) - (version ,(composer-package-version composer-package)) - (source (origin - ,@(if git? - `((method git-fetch) - (uri (git-reference - (url ,(composer-source-url source)) - (commit ,(composer-source-reference source)))) - (file-name (git-file-name name version)) - (sha256 - (base32 - ,(bytevector->nix-base32-string - (file-hash temp (negate vcs-file?) #t))))) - `((method url-fetch) - (uri ,(composer-source-url source)) - (sha256 (base32 ,(guix-hash-url temp))))))) - (build-system composer-build-system) - ,@(if (null? dependencies) - '() - `((inputs - (list ,@(map string->symbol dependencies))))) - ,@(if (null? dev-dependencies) - '() - `((native-inputs - (list ,@(map string->symbol dev-dependencies))))) - (synopsis "") - (description ,(composer-package-description composer-package)) - (home-page ,(composer-package-homepage composer-package)) - (license ,(or (composer-package-license composer-package) - 'unknown-license!)))))))) + `(define-public ,(string->symbol + (composer-package-name composer-package)) + (package + (name ,(composer-package-name composer-package)) + (version ,(composer-package-version composer-package)) + (source + (origin + ,@(if git? + `((method git-fetch) + (uri (git-reference + (url ,(if (string-suffix? + ".git" + (composer-source-url source)) + (string-drop-right + (composer-source-url source) + (string-length ".git")) + (composer-source-url source))) + (commit ,(composer-source-reference source)))) + (file-name (git-file-name name version)) + (sha256 + (base32 + ,(bytevector->nix-base32-string + (file-hash* temp))))) + `((method url-fetch) + (uri ,(composer-source-url source)) + (sha256 (base32 ,(guix-hash-url temp))))))) + (build-system composer-build-system) + ,@(if (null? dependencies) + '() + `((inputs + (list ,@(map string->symbol dependencies))))) + ,@(if (null? dev-dependencies) + '() + `((native-inputs + (list ,@(map string->symbol dev-dependencies))))) + (synopsis "") + (description ,(composer-package-description composer-package)) + (home-page ,(composer-package-homepage composer-package)) + (license ,(or (composer-package-license composer-package) + 'unknown-license!))))))))) (define composer->guix-package (memoize - (lambda* (package-name #:key version #:allow-other-keys) + (lambda* (package-name #:key (version #f) #:allow-other-keys) "Fetch the metadata for PACKAGE-NAME from packagist.org, and return the `package' s-expression corresponding to that package, or #f on failure." - (let ((package (composer-fetch package-name version))) + (let ((package (composer-fetch package-name #:version version))) (and package - (let* ((package (json->composer-package package)) - (dependencies-names (composer-package-require package)) + (let* ((dependencies-names (composer-package-require package)) (dev-dependencies-names (composer-package-dev-require package))) (values (make-php-sexp package) (append dependencies-names dev-dependencies-names)))))))) @@ -238,14 +239,13 @@ (define (string->license str) (define (php-package? package) "Return true if PACKAGE is a PHP package from Packagist." (and - (eq? (build-system-name (package-build-system package)) 'composer) - (string-prefix? "php-" (package-name package)))) + (eq? (package-build-system package) composer-build-system) + (string-prefix? "php-" (package-name package)))) (define (latest-release package) "Return an for the latest release of PACKAGE." (let* ((php-name (guix-package->composer-name package)) - (metadata (composer-fetch php-name)) - (package (json->composer-package metadata)) + (package (composer-fetch php-name)) (version (composer-package-version package)) (url (composer-source-url (composer-package-source package)))) (upstream-source