From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp10.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms0.migadu.com with LMTPS id 0KKIJ3hR2WEVWgAAgWs5BA (envelope-from ) for ; Sat, 08 Jan 2022 09:55:20 +0100 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp10.migadu.com with LMTPS id eKpEIHhR2WGNdQEAG6o9tA (envelope-from ) for ; Sat, 08 Jan 2022 09:55:20 +0100 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 1C9F434B4A for ; Sat, 8 Jan 2022 09:55:20 +0100 (CET) Received: from localhost ([::1]:32988 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1n67VP-0002HZ-7m for larch@yhetil.org; Sat, 08 Jan 2022 03:55:19 -0500 Received: from eggs.gnu.org ([209.51.188.92]:44908) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1n67LS-0002pN-6I for guix-patches@gnu.org; Sat, 08 Jan 2022 03:45:02 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:53431) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1n67LR-0004Af-MN for guix-patches@gnu.org; Sat, 08 Jan 2022 03:45:01 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1n67LR-0000no-Kd for guix-patches@gnu.org; Sat, 08 Jan 2022 03:45:01 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#51838] [PATCH v9 03/41] guix: node-build-system: Add JSON utilities. Resent-From: Philip McGrath Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 08 Jan 2022 08:45:01 +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: 51838@debbugs.gnu.org Cc: Timothy Sample , Philip McGrath , Pierre Langlois , Liliana Marie Prikler , Leo Famulari , Jelle Licht Received: via spool by 51838-submit@debbugs.gnu.org id=B51838.16416314452820 (code B ref 51838); Sat, 08 Jan 2022 08:45:01 +0000 Received: (at 51838) by debbugs.gnu.org; 8 Jan 2022 08:44:05 +0000 Received: from localhost ([127.0.0.1]:46294 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n67KW-0000jQ-QA for submit@debbugs.gnu.org; Sat, 08 Jan 2022 03:44:05 -0500 Received: from mail-qt1-f182.google.com ([209.85.160.182]:46779) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n67KV-0000iM-Nz for 51838@debbugs.gnu.org; Sat, 08 Jan 2022 03:44:04 -0500 Received: by mail-qt1-f182.google.com with SMTP id v7so4758568qtw.13 for <51838@debbugs.gnu.org>; Sat, 08 Jan 2022 00:44:03 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=philipmcgrath.com; s=google; h=from:to:cc:subject:date:message-id:in-reply-to:references :mime-version:content-transfer-encoding; bh=7Ud0HsJ2lf4LEaRqtAQ/CwCD+dR7a3xvoPSgVdnRIkE=; b=a4pi4mFxxzfDkLYBKWWoQeO3mYN/iN0uEguul6zUOoezRzJ4cZsWxpNmUBjgmT2q8s zAd0UWETq1z6qIjXFYKVcxF3x2110Y/CKL+Qadax9X2BeAMwAnM2m0c3SjUBbhUArjSy hzsxbjkPJZlP3H5BUvRZjdqHKrnPKVOqCJf7/BGqV9JmdsZUM01U74yqCJoALaf2X+u7 Qv+UdRFg5my7dr742/1L96NAJMJsby/wl+x65NjkfrHL5Xk4tKUdRT1XWA5gr7L7Z1AK xe2XPt+sCTJNPP0AYPbT0rGlqxmlG3jKu8gV/S40ZnYRUqjVfdroxIXar4dwLjeMFdaq ZN1w== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:from:to:cc:subject:date:message-id:in-reply-to :references:mime-version:content-transfer-encoding; bh=7Ud0HsJ2lf4LEaRqtAQ/CwCD+dR7a3xvoPSgVdnRIkE=; b=sjEv5iP2TxelSHYRnTHRQh0jSd2n605w4wmdwcmg+/lkxmhBJf/fptSz2J9wDDP1vW p4T5CKSG0kT+pB4uMnda+6EhKJPpqNo524e+Wjy+Q857IVUdjV8B31rhS/O83skrhOe+ zdyp7PV9eaKVhyTGky5y0dLRFqKKwH6XS8MuL4pdatStJEUC59KkHdoh/hS0Ouf5xmSp KEs3358DMDe7DYpaY8B3mOECZv3KM+Boy30LEgn477rLRwnhP1INybTCBeQRAmhpS1g0 DoTDDTnRDFPzwByhF+G1VAOAu6eV5PC2eBZDITwIRWdfIS2Gk3xeD9jZNjWidbdM5VAQ 7i8Q== X-Gm-Message-State: AOAM531KTDn/56fsFHXWedEiABIc8fXDDZ6pBZX0McZZzWbpKwllEQyl QCgiZgkUYJXdE5tRfRwQ3o1oZB1GgySAAHmA X-Google-Smtp-Source: ABdhPJyqJHH91qO0Iv4JFbpogpepL47mSB9+9RPEbVfTDyTBWdLUaLWi7uPHfWoHw6Se76i0mWiRZQ== X-Received: by 2002:ac8:5885:: with SMTP id t5mr10128822qta.662.1641631438044; Sat, 08 Jan 2022 00:43:58 -0800 (PST) Received: from localhost (c-73-125-89-242.hsd1.fl.comcast.net. [73.125.89.242]) by smtp.gmail.com with UTF8SMTPSA id e14sm660205qts.15.2022.01.08.00.43.57 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Sat, 08 Jan 2022 00:43:57 -0800 (PST) From: Philip McGrath Date: Sat, 8 Jan 2022 03:41:51 -0500 Message-Id: <20220108084229.362642-4-philip@philipmcgrath.com> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20220108084229.362642-1-philip@philipmcgrath.com> References: <64e08d3a1838ed8507f33fae895545372960522f.camel@gmail.com> <7b04af28bbd57c67093ce8f33a648efec89693bd.camel@gmail.com> <441bfeb0-eb6e-81f6-488b-cdf1b09a78ef@philipmcgrath.com> <20220108084229.362642-1-philip@philipmcgrath.com> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Migadu-Flow: FLOW_IN X-Migadu-Country: US ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1641632120; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=OSURs5jy0LVHNqlj4ya9N8P4Vfny9gzC3eyGJQKV/ZM=; b=hSvu8lQXxx5xz2am5LE4c45LyHkMGnuYkVJK4p5xQ1Ea20PQle1XaEbgDOiQ4Af6dlUSkv 8bDb6oKOW7sLbdjGLVyrTnajodc1QcaI15bfkOyB0RAXQur2gZU2UoPQgT6wD/wbOD41We Msuqrq84aMmOzg6rOUdDA5hglUq+kRE6+GaA080af6QBxL0FoOvgRPbGx8gV7cfrha3C0u B6iDb6YvXKXwCdh/fW5YP8Kl22gVU48PxtuAJxySynR6jKZO73enNVkaoTGw6K+FaKUU33 8ZVaiysBPmuckmdW1u0zdFFmptfrtJJC27yafMpbFhzQhQ6YQ0w2YiUIXTv50Q== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1641632120; a=rsa-sha256; cv=none; b=tOsLVyXCk5CVY2IOTGctbqQITfCFbeI/Q7ZkDDjqAcaOnUYAsQaj7Fw8zkz/F79GhpZJl2 +soKk6NdJs/MX7ZDfECdGVstwk5WMX8MtTAzo2jeDziMekI9gdpObQExWRazgwvkFPoF4G huHA786ebSmV6oppqkyqhVkBUJBj7kBa6u5CHELQXS/f0Q07wPh3u8QzM01Nil0K679D8N WioPH13sQTvAXZhgonZfoYbjjN+lOrUFQjnS4T+PnOIyRwLF5ix9lrfm2/aSM5wXgRXv8k 0vE5ijLOGMnF0dKJglsXLfHxOcVPBoObiOXhY7EvXArOMUGXAGs9Qwl8gy/vEg== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=philipmcgrath.com header.s=google header.b=a4pi4mFx; dmarc=none; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" X-Migadu-Spam-Score: 0.40 Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=philipmcgrath.com header.s=google header.b=a4pi4mFx; dmarc=none; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" X-Migadu-Queue-Id: 1C9F434B4A X-Spam-Score: 0.40 X-Migadu-Scanner: scn1.migadu.com X-TUID: mLck2IfqiRJz 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 | 146 +++++++++++++++++++++++++------ 1 file changed, 117 insertions(+), 29 deletions(-) diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index 2d7a3bdc67..60c75dc85d 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,104 @@ (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 to which KEY is mapped in JS. If no such mapping exists, +PROC is instead applied to DEFAULT, or to '#f' is no DEFAULT is specified. +The update takes place from left to right, so later UPDATERs will receive the +values returned by earlier UPDATERs for the same KEY." + (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 +141,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 +165,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) '()))) + (define resolve-dependencies + (match-lambda + (('@ . alist) + (cons '@ (map (match-lambda + ((key . value) + (cons key (hash-ref index key value)))) + alist))))) - (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)))) + (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 +205,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~%")) -- 2.32.0