From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp11.migadu.com ([2001:41d0:403:4789::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms9.migadu.com with LMTPS id WLd0EqV0tWS8DgEASxT56A (envelope-from ) for ; Mon, 17 Jul 2023 19:04:37 +0200 Received: from aspmx1.migadu.com ([2001:41d0:403:4789::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp11.migadu.com with LMTPS id KLyzEqV0tWRpRAAA9RJhRA (envelope-from ) for ; Mon, 17 Jul 2023 19:04:37 +0200 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 84588455FD for ; Mon, 17 Jul 2023 19:04:36 +0200 (CEST) Authentication-Results: aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=spork.org header.s=dkim header.b=U+kg1F1D; spf=pass (aspmx1.migadu.com: domain of "bug-guix-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="bug-guix-bounces+larch=yhetil.org@gnu.org"; dmarc=pass (policy=none) header.from=gnu.org ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1689613477; h=from:from:sender:sender:reply-to: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=vYu6VRRuTeYBtz2vSh3wm4LEVQKcQXNpCMy3LJtFqqw=; b=DJezrYp4aGXub9gjgb9qozfTG6c3v1JIvk1MzjcU70QMoxsbuiaZy32MrHy2itRwz9JYDs MAvM2FIaYFb8hI6Lk7vPRS7EEDrE3BddrGPqSwf5QEQ0jVKpHoAoQB4SV3imkPIV1QrwZC Giq2j+uPuV73T/8SuaXKlE8lTGHULl1X5Xgzm+8DaPYNMaQ1JNHEFk7LLEVsOHKkoU4zG4 Rwe+SMxdg/Ur9M768TqV0HE2TNQFvcnAqt/2MgHITVLpPrB7KUl+NDd+2zmn+26uSELSKQ JTYD++hhTpTj9yy6RSqO9i7/lT4iG5hT1FZYuB/LEZhSBZ6ZsRp/8gfbyjmvfw== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1689613477; a=rsa-sha256; cv=none; b=ciCS+v+9dbwD5qoWw8U48aCxj/CAQWkXo63Q/2FjcPxhFkda6EfdIewRumBjkuSy8eQxJ+ FYWMeL/cTv78Z9sriznVrZHmWogeuHHl9eFbootf9RGt5UdkbfHr3zh5l/xXvTc0898eU3 EeNo/b2iL6pXhnB/RJr1LST8ywD9EinejnJHBMDcBu/Ghc0UxR38AYW2ESnOA0YeFaEYe3 Nf3tPqFrVgB2ImDxWS97/xDeaRw7+mb4Bzo7ukxQiOfuJSRPOKklglucYtqbaHCX8e9cF/ faOFHqQ+n1/Cu+B8rFXCRga4UHKk5ZKntSFM0Bd7iy1VP0ULUQU839mcLuVbcg== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=spork.org header.s=dkim header.b=U+kg1F1D; spf=pass (aspmx1.migadu.com: domain of "bug-guix-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="bug-guix-bounces+larch=yhetil.org@gnu.org"; dmarc=pass (policy=none) header.from=gnu.org Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1qLRdn-00026m-Sr; Mon, 17 Jul 2023 13:04:07 -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 1qLRdi-00026M-LS for bug-guix@gnu.org; Mon, 17 Jul 2023 13:04:02 -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 1qLRdi-0000QD-B9 for bug-guix@gnu.org; Mon, 17 Jul 2023 13:04:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1qLRdh-0002kE-T1 for bug-guix@gnu.org; Mon, 17 Jul 2023 13:04:01 -0400 X-Loop: help-debbugs@gnu.org Subject: bug#64106: [PATCH] gnu: services: Revert to deleting and updating all matching services References: In-Reply-To: Resent-From: Brian Cully Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Mon, 17 Jul 2023 17:04:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 64106 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: 64106@debbugs.gnu.org Cc: Brian Cully Received: via spool by 64106-submit@debbugs.gnu.org id=B64106.168961338610477 (code B ref 64106); Mon, 17 Jul 2023 17:04:01 +0000 Received: (at 64106) by debbugs.gnu.org; 17 Jul 2023 17:03:06 +0000 Received: from localhost ([127.0.0.1]:50837 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qLRco-0002iu-1y for submit@debbugs.gnu.org; Mon, 17 Jul 2023 13:03:06 -0400 Received: from coleridge.kublai.com ([166.84.7.167]:51893 helo=mail.spork.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1qLRcj-0002iP-3J for 64106@debbugs.gnu.org; Mon, 17 Jul 2023 13:03:04 -0400 Received: from psyduck.jhoto.kublai.com (ool-18b8e9e7.dyn.optonline.net [24.184.233.231]) by mail.spork.org (Postfix) with ESMTPSA id 8CCAE3689; Mon, 17 Jul 2023 13:02:30 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=spork.org; s=dkim; t=1689613350; bh=wznLu54wUL2Qn+9jlfQ+V7taIEXgJpNCPGXJiXPIqZ8=; h=From:To:Cc:Subject:Date; b=U+kg1F1Daaju3aynLPJKJ6BSlFAClc+F0SgzeSa2aTC8dmsqDZsR7V8UVkaquF8qx G6gjFx5+zWQBKm2KbDJxzhARtBwf8wM1/GeVM9wSJgWX+G0MNtBXXm0b06JFUAe+5V oN3H40kMInNwDcyzMugPkJCNP1DQHibPNQWtJ5as= Date: Mon, 17 Jul 2023 13:02:19 -0400 Message-ID: X-Mailer: git-send-email 2.41.0 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: bug-guix@gnu.org List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Reply-to: Brian Cully From: Brian Cully via Bug reports for GNU Guix Errors-To: bug-guix-bounces+larch=yhetil.org@gnu.org Sender: bug-guix-bounces+larch=yhetil.org@gnu.org X-Migadu-Country: US X-Migadu-Flow: FLOW_IN X-Migadu-Spam-Score: -3.66 X-Spam-Score: -3.66 X-Migadu-Queue-Id: 84588455FD X-Migadu-Scanner: mx1.migadu.com X-TUID: vfZIJn8sKmD0 This patch reverts the behavior introduced in 181951207339508789b28ba7cb914f983319920f which caused ‘modify-services’ clauses to only match a single instance of a service. We will now match all service instances when doing a deletion or update, while still raising an exception when trying to match against a service that does not exist in the services list, or which was deleted explicitly by a ‘delete’ clause (or an update clause that returns ‘#f’ for the service). Fixes: #64106 * gnu/services.scm (%modify-services): New procedure. (modify-services): Use it. (apply-clauses): Add DELETED-SERVICES argument, change to modify one service at a time. * tests/services.scm ("modify-services: delete then modify"), ("modify-services: modify then delete"), ("modify-services: delete multiple services of the same type"), ("modify-services: modify multiple services of the same type"): New tests. --- gnu/services.scm | 95 +++++++++++++++++++++++++++------------------- tests/services.scm | 68 +++++++++++++++++++++++++++++++++ 2 files changed, 124 insertions(+), 39 deletions(-) diff --git a/gnu/services.scm b/gnu/services.scm index 109e050a23..4c5b9b16df 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -320,45 +320,62 @@ (define-syntax clause-alist ((_) '()))) -(define (apply-clauses clauses services) - "Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICES, a list -of services. Use each clause at most once; raise an error if a clause was not -used." - (let loop ((services services) - (clauses clauses) - (result '())) - (match services - (() - (match clauses - (() ;all clauses fired, good - (reverse result)) - (((kind _ properties) _ ...) ;one or more clauses didn't match - (raise (make-compound-condition - (condition - (&error-location - (location (source-properties->location properties)))) - (formatted-message - (G_ "modify-services: service '~a' not found in service list") - (service-type-name kind))))))) - ((head . tail) - (let ((service clauses - (fold2 (lambda (clause service remainder) - (if service - (match clause - ((kind proc properties) - (if (eq? kind (service-kind service)) - (values (proc service) remainder) - (values service - (cons clause remainder))))) - (values #f (cons clause remainder)))) - head +(define (apply-clauses clauses service deleted-services) + (define (raise-if-deleted kind properties) + (match (find (lambda (deleted) + (match deleted + ((deleted-kind _) + (eq? kind deleted-kind)))) + deleted-services) + ((_ deleted-properties) + (raise (make-compound-condition + (condition + (&error-location + (location (source-properties->location properties)))) + (formatted-message + (G_ "modify-services: service '~a' was deleted here: ~a") + (service-type-name kind) + (source-properties->location deleted-properties))))) + (_ #t))) + + (match clauses + (((kind proc properties) . rest) + (begin + (raise-if-deleted kind properties) + (if (eq? (and service (service-kind service)) + kind) + (let ((new-service (proc service))) + (apply-clauses rest new-service + (if new-service + deleted-services + (cons (list kind properties) + deleted-services)))) + (apply-clauses rest service deleted-services)))) + (() + service))) + +(define (%modify-services services clauses) + (define (raise-if-not-found clause) + (match clause + ((kind _ properties) + (when (not (find (lambda (service) + (eq? kind (service-kind service))) + services)) + (raise (make-compound-condition + (condition + (&error-location + (location (source-properties->location properties)))) + (formatted-message + (G_ "modify-services: service '~a' not found in service list") + (service-type-name kind)))))))) + + (for-each raise-if-not-found clauses) + (reverse (filter-map identity + (fold (lambda (service services) + (cons (apply-clauses clauses service '()) + services)) '() - clauses))) - (loop tail - (reverse clauses) - (if service - (cons service result) - result))))))) + services)))) (define-syntax modify-services (syntax-rules () @@ -393,7 +410,7 @@ (define-syntax modify-services all the MINGETTY-SERVICE-TYPE instances, and it deletes instances of the UDEV-SERVICE-TYPE." ((_ services clauses ...) - (apply-clauses (clause-alist clauses ...) services)))) + (%modify-services services (clause-alist clauses ...))))) ;;; diff --git a/tests/services.scm b/tests/services.scm index 20ff4d317e..98b584f6c0 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -370,4 +370,72 @@ (define-module (test-services) (modify-services services (t2 value => 22))))) +(test-error "modify-services: delete then modify" + #t + (let* ((t1 (service-type (name 't1) + (extensions '()) + (description ""))) + (t2 (service-type (name 't2) + (extensions '()) + (description ""))) + (t3 (service-type (name 't3) + (extensions '()) + (description ""))) + (services (list (service t1 1) (service t2 2) (service t3 3)))) + (map service-value + (modify-services services + (delete t2) + (t2 value => 22))))) + +(test-equal "modify-services: modify then delete" + '(2 3) + (let* ((t1 (service-type (name 't1) + (extensions '()) + (description ""))) + (t2 (service-type (name 't2) + (extensions '()) + (description ""))) + (t3 (service-type (name 't3) + (extensions '()) + (description ""))) + (services (list (service t1 1) (service t2 2) (service t3 3)))) + (map service-value + (modify-services services + (t1 value => 11) + (delete t1))))) + +(test-equal "modify-services: delete multiple services of the same type" + '(1 3) + (let* ((t1 (service-type (name 't1) + (extensions '()) + (description ""))) + (t2 (service-type (name 't2) + (extensions '()) + (description ""))) + (t3 (service-type (name 't3) + (extensions '()) + (description ""))) + (services (list (service t1 1) (service t2 2) + (service t2 2) (service t3 3)))) + (map service-value + (modify-services services + (delete t2))))) + +(test-equal "modify-services: modify multiple services of the same type" + '(1 12 13 4) + (let* ((t1 (service-type (name 't1) + (extensions '()) + (description ""))) + (t2 (service-type (name 't2) + (extensions '()) + (description ""))) + (t3 (service-type (name 't3) + (extensions '()) + (description ""))) + (services (list (service t1 1) (service t2 2) + (service t2 3) (service t3 4)))) + (map service-value + (modify-services services + (t2 value => (+ value 10)))))) + (test-end) base-commit: 29a7bd209c7a37bbc0c46a18de6d81bf0569041b -- 2.41.0