From patchwork Thu Dec 30 07:38:41 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Liliana Marie Prikler X-Patchwork-Id: 36009 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 4F1DB27BBEA; Thu, 6 Jan 2022 18:25:48 +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=-1.7 required=5.0 tests=BAYES_00,DKIM_ADSP_CUSTOM_MED, DKIM_INVALID,DKIM_SIGNED,FREEMAIL_FROM,MAILING_LIST_MULTI, PP_MIME_FAKE_ASCII_TEXT,RCVD_IN_MSPIKE_H3,RCVD_IN_MSPIKE_WL, SPF_HELO_PASS autolearn=no 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 9CAA327BBE9 for ; Thu, 6 Jan 2022 18:25:47 +0000 (GMT) Received: from localhost ([::1]:40506 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1n5XSM-0006OM-Pe for patchwork@mira.cbaines.net; Thu, 06 Jan 2022 13:25:46 -0500 Received: from eggs.gnu.org ([209.51.188.92]:60662) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1n5XRh-0006Kh-1g for guix-patches@gnu.org; Thu, 06 Jan 2022 13:25:05 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:49297) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1n5XRg-0000h7-OY for guix-patches@gnu.org; Thu, 06 Jan 2022 13:25:04 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1n5XRf-0004y0-Kz for guix-patches@gnu.org; Thu, 06 Jan 2022 13:25:03 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#51838] [PATCH v8 03/41] guix: node-build-system: Add JSON utilities. References: <20211114124151.36743-1-philip@philipmcgrath.com> In-Reply-To: <20211114124151.36743-1-philip@philipmcgrath.com> Resent-From: Liliana Marie Prikler Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 06 Jan 2022 18:25:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 51838 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: Philip McGrath Cc: 51838@debbugs.gnu.org, Timothy Sample , Pierre Langlois , Jelle Licht , Leo Famulari Received: via spool by 51838-submit@debbugs.gnu.org id=B51838.164149347418835 (code B ref 51838); Thu, 06 Jan 2022 18:25:03 +0000 Received: (at 51838) by debbugs.gnu.org; 6 Jan 2022 18:24:34 +0000 Received: from localhost ([127.0.0.1]:42159 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n5XRA-0004tV-NU for submit@debbugs.gnu.org; Thu, 06 Jan 2022 13:24:33 -0500 Received: from mail-wm1-f66.google.com ([209.85.128.66]:41642) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n5XR2-0004rd-Lz for 51838@debbugs.gnu.org; Thu, 06 Jan 2022 13:24:25 -0500 Received: by mail-wm1-f66.google.com with SMTP id g186-20020a1c9dc3000000b0034755f8fa58so926619wme.0 for <51838@debbugs.gnu.org>; Thu, 06 Jan 2022 10:24:24 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=from:date:subject:to:cc:content-transfer-encoding:message-id :mime-version; bh=k8CcS3QxMjEeZlIJtz2mVShJRXVutz7Wr98cMR8kBhQ=; b=F4iNYGzfMXwzGoggmOiSUCKG6AszNowi+kw0fsUgL8uXWIwNS/JlXLfMuQf65oAOb5 DdgMBCiD72W3k9PM0/LzBxXsRM0Jmy+kHkMkQAJUx3qTS5JlzABYACHuJVyiPJb6MeQX OBLAfUsgxaGF8wf0hQwVo6Yf2od22y9BK/ztmMKILYyhuOQwfnTHRhYOsF61Wl+l3Gc6 lRrVc1VikDcufAIq5RTH+0gCMBFl/44CUaxVnmvzAOXklfEwsI1WZCOjB8V3p+dWMSEn djMo8tnumsCweBXySjoPLuhZy5KPRRUaHISLq9TnCHUVOO5+86Jfw+pwWL3KDixiGb1q k6mw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:from:date:subject:to:cc :content-transfer-encoding:message-id:mime-version; bh=k8CcS3QxMjEeZlIJtz2mVShJRXVutz7Wr98cMR8kBhQ=; b=NI3s3XuqbCYFE4dQlwGW07FG4JtoohwanEqankngI/DRost5a26Ft4b1U+CRPKH21I DjYKovvY68d0tuARCPOPMTzmTP0ismLc9qFGMLzAKKp8UtdfezDR0ipG7ry+9JYE5cdX YzrsGNTOVK0WPhH3jwFzk+Qwx0h8dup47Xq6sMLUEw1INk8m0IA1CiHJfpvMLvO8HeV8 BmVib2xZrrfnaLthK8ZtP+fkD8ZqbeyF85BNBJldtuKy2SiTxE2YHfgE6TIGXJ5iMoAA EPkFXgESOBFtCqoeEd+O3dh/GqD2beizwyv2A0ppWMMBz6vHM/r6Fm+CcIuF+TMeVhkl gfGw== X-Gm-Message-State: AOAM531TtA6/qpBJIluvGo4jDEqXfuYXVoy5FQXTNUFqKpHTlAt38pPV RFSzpJ9YvAg5iL2sx6/YYyo= X-Google-Smtp-Source: ABdhPJwM8th2RpMaavQIkuK6SEswJf/eI3dm5QMXg1pWyoUaJQ1FZgwgaugJWLwmgb1iwOOp+CrGNQ== X-Received: by 2002:a7b:c853:: with SMTP id c19mr6945728wml.2.1641493459092; Thu, 06 Jan 2022 10:24:19 -0800 (PST) Received: from nijino.fritz.box (85-127-52-93.dsl.dynamic.surfer.at. [85.127.52.93]) by smtp.gmail.com with ESMTPSA id b17sm2693311wrq.91.2022.01.06.10.24.18 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 06 Jan 2022 10:24:18 -0800 (PST) From: Liliana Marie Prikler Date: Thu, 30 Dec 2021 02:38:41 -0500 Message-ID: <71ee87241c6c8a2a49c7cff916b7e1e9d508e020.camel@gmail.com> MIME-Version: 1.0 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: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches This commit adds several utility functions for non-destructive transformation of the JSON representation used by (guix build json), particularly for purely functional update of JSON objects. They ought to eventually be exported from their own module, but for now are kept private to allow experimentation. * guix/build/node-build-system.scm (assoc-ref*, jsobject-ref, alist-pop) (alist-update, jsobject-update*, jsobject-union): New variables. (with-atomic-json-file-replacement): New public variable. (module-name, build, patch-dependencies): Use them. Do not resort to unsafe alist primitives from Guile core. Co-authored-by: Liliana Marie Prikler --- guix/build/node-build-system.scm | 145 ++++++++++++++++++++++++------- 1 file changed, 115 insertions(+), 30 deletions(-) diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index 2d7a3bdc67..c6602b876b 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016, 2020 Jelle Licht ;;; Copyright © 2019, 2021 Timothy Sample ;;; Copyright © 2021 Philip McGrath +;;; Copyright © 2021 Liliana Marie Prikler ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,14 +27,101 @@ (define-module (guix build node-build-system) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) #:export (%standard-phases + with-atomic-json-file-replacement node-build)) -;; Commentary: -;; -;; Builder-side code of the standard Node/NPM package install procedure. -;; -;; Code: +(define (with-atomic-json-file-replacement file proc) + "Like 'with-atomic-file-replacement', but PROC is called with a single +argument---the result of parsing FILE's contents as json---and should a value +to be written as json to the replacement FILE." + (with-atomic-file-replacement file + (lambda (in out) + (write-json (proc (read-json in)) out)))) + +(define* (assoc-ref* alist key #:optional default) + "Like assoc-ref, but return DEFAULT instead of #f if no value exists." + (match (assoc key alist) + (#f default) + ((_ . value) value))) + +(define* (jsobject-ref obj key #:optional default) + (match obj + (('@ . alist) (assoc-ref* alist key default)))) + +(define* (alist-pop alist key #:optional (= equal?)) + "Return two values, the first pair in ALIST with key KEY, and the other +elements. Equality calls are made as (= KEY ALISTCAR)." + (define (found? pair) + (= key (car pair))) + + (let ((before after (break found? alist))) + (if (pair? after) + (values (car after) (append before (cdr after))) + (values #f before)))) + +(define* (alist-update alist key proc #:optional default (= equal?)) + "Return an association list like ALIST, but with KEY mapped to the result of +PROC applied to the first value found under the comparison (= KEY ALISTCAR). +If no such value exists, use DEFAULT instead. +Unlike acons, this removes the previous association of KEY (assuming it is +unique), but the result may still share storage with ALIST." + (let ((pair rest (alist-pop alist key =))) + (acons key + (proc (if (pair? pair) + (cdr pair) + default)) + rest))) + +(define (jsobject-update* js . updates) + "Return a json object like JS, but with all UPDATES applied. Each update +is a list (KEY PROC [DEFAULT]), so that KEY is mapped to the result of +PROC applied to the value found for it, or DEFAULT otherwise." + (match js + (('@ . alist) + (let loop ((alist alist) + (updates updates)) + (match updates + (() (cons '@ alist)) + (((key proc) . updates) + (loop (alist-update alist key proc #f equal?) updates)) + (((key proc default) . updates) + (loop (alist-update alist key proc default equal?) updates))))))) + +(define (jsobject-union combine seed . objects) + "Merge OBJECTS into SEED by applying (COMBINE KEY VAL0 VAL), where VAL0 +is the value found in the (possibly updated) SEED and VAL is the new value +found in one of the OBJECTS." + (match seed + (('@ . aseed) + (match objects + (() seed) + ((('@ . alists) ...) + (cons + '@ + (fold (lambda (alist aseed) + (if (null? aseed) alist + (fold + (match-lambda* + (((k . v) aseed) + (let ((pair tail (alist-pop alist k))) + (match pair + (#f (acons k v aseed)) + ((_ . v0) (acons k (combine k v0 v) aseed)))))) + aseed + alist))) + aseed + alists))))))) + +;; Possibly useful helper functions: +;; (define (newest key val0 val) val) +;; (define (unkeyed->keyed proc) (lambda (_key val0 val) (proc val0 val))) + + +;;; +;;; Phases. +;;; (define (set-home . _) (with-directory-excursion ".." @@ -50,7 +138,7 @@ (define (set-home . _) (define (module-name module) (let* ((package.json (string-append module "/package.json")) (package-meta (call-with-input-file package.json read-json))) - (assoc-ref package-meta "name"))) + (jsobject-ref package-meta "name"))) (define (index-modules input-paths) (define (list-modules directory) @@ -74,27 +162,26 @@ (define* (patch-dependencies #:key inputs #:allow-other-keys) (define index (index-modules (map cdr inputs))) - (define (resolve-dependencies package-meta meta-key) - (fold (lambda (key+value acc) - (match key+value - ('@ acc) - ((key . value) (acons key (hash-ref index key value) acc)))) - '() - (or (assoc-ref package-meta meta-key) '()))) - - (with-atomic-file-replacement "package.json" - (lambda (in out) - (let ((package-meta (read-json in))) - (assoc-set! package-meta "dependencies" - (append - '(@) - (resolve-dependencies package-meta "dependencies") - (resolve-dependencies package-meta "peerDependencies"))) - (assoc-set! package-meta "devDependencies" - (append - '(@) - (resolve-dependencies package-meta "devDependencies"))) - (write-json package-meta out)))) + (define resolve-dependencies + (match-lambda + (('@ . alist) + (cons '@ (map (match-lambda + ((key . value) + (cons key (hash-ref index key value)))) + alist))))) + + (with-atomic-json-file-replacement "package.json" + (lambda (pkg-meta) + (jsobject-update* + pkg-meta + `("devDependencies" ,resolve-dependencies (@)) + `("dependencies" ,(lambda (deps) + (resolve-dependencies + (jsobject-union + (lambda (k a b) b) + (jsobject-ref pkg-meta "peerDependencies" '(@)) + deps))) + (@))))) #t) (define* (delete-lockfiles #:key inputs #:allow-other-keys) @@ -115,9 +202,7 @@ (define* (configure #:key outputs inputs #:allow-other-keys) (define* (build #:key inputs #:allow-other-keys) (let ((package-meta (call-with-input-file "package.json" read-json))) - (if (and=> (assoc-ref package-meta "scripts") - (lambda (scripts) - (assoc-ref scripts "build"))) + (if (jsobject-ref (jsobject-ref package-meta "scripts" '(@)) "build" #f) (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm"))) (invoke npm "run" "build")) (format #t "there is no build script to run~%"))