From patchwork Sat Nov 19 22:24:50 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 44690 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 68C6A27BBED; Sat, 19 Nov 2022 22:27:00 +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=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2,SPF_HELO_PASS, URIBL_BLOCKED autolearn=ham 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 E7A2127BBE9 for ; Sat, 19 Nov 2022 22:26:58 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1owWHv-0007Kt-Qq; Sat, 19 Nov 2022 17:26:15 -0500 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 1owWHi-0007JE-7g for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWHh-0004SW-Vg for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:01 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1owWHh-0004gY-JK for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:01 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#59390] [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time. References: <20221119222326.10644-1-ludo@gnu.org> In-Reply-To: <20221119222326.10644-1-ludo@gnu.org> Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 19 Nov 2022 22:26:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 59390 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 59390@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 59390-submit@debbugs.gnu.org id=B59390.166889671117879 (code B ref 59390); Sat, 19 Nov 2022 22:26:01 +0000 Received: (at 59390) by debbugs.gnu.org; 19 Nov 2022 22:25:11 +0000 Received: from localhost ([127.0.0.1]:41579 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWGs-0004eG-Am for submit@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:11 -0500 Received: from eggs.gnu.org ([209.51.188.92]:40282) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWGp-0004e1-UX for 59390@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:08 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1owWGk-00046m-N5; Sat, 19 Nov 2022 17:25:02 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:Date:Subject:To:From:in-reply-to: references; bh=hWBHwMNMZZHL/ndVgn37Mm3AsFQtPcAvVT/hCt2XNXw=; b=kagDA4tKWnqFN6 z/ssxgyn9Nu4dbOaOAvPseWIuq9BuLCj2y/OwKSL+S9r4hiNYgz7oUCEvBc6VIIGxIveutAi95J+O WPjDs/gOSBFGRcMVcVi9B9N+qUQFs17CgWRbRoQWiMvMLGa4BXgCqhu+yhCAu1s0yqQgUMiKj92jK XX5Y9Pppdam3XW5HY+NdsA4371qHNaDgUo03aXTHiJM8Z4/UcXm40Ssd5sBeHfsmO+vIcbdyqLuXE zibt522BM52OurUoj4O2AEkV2hB5E0RmVt4alWAsqN6ombXi8CHW+p9tEohJenZWakyVSahZ2HHar aTvyGU3C06EurRc4LNbQ==; Received: from 91-160-117-201.subs.proxad.net ([91.160.117.201] helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWGj-0006LD-Qb; Sat, 19 Nov 2022 17:25:02 -0500 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sat, 19 Nov 2022 23:24:50 +0100 Message-Id: <20221119222454.10759-1-ludo@gnu.org> X-Mailer: git-send-email 2.38.1 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-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches This allows 'match-record' to be more efficient (field offsets are computed at compilation time) and to report unknown fields at macro-expansion time. * guix/records.scm (map-fields): New macro. (define-record-type*)[rtd-identifier]: New procedure. Define TYPE as a macro and use a separate identifier for the RTD. (lookup-field, match-record-inner): New macros. (match-record): Rewrite in terms of 'match-error-inner'. * tests/records.scm ("record-match, simple") ("record-match, unknown field"): New tests. * gnu/services/cuirass.scm (cuirass-shepherd-service): Rename 'log-file' local variable to 'main-log-file'. * gnu/services/getmail.scm (serialize-getmail-configuration-file): Move after definition. --- gnu/services/cuirass.scm | 4 +- gnu/services/getmail.scm | 22 +++++----- guix/records.scm | 87 +++++++++++++++++++++++++++++++++++----- tests/records.scm | 33 +++++++++++++++ 4 files changed, 122 insertions(+), 24 deletions(-) diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index 52de5ca7c0..d7c6ab9877 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -125,7 +125,7 @@ (define (cuirass-shepherd-service config) (let ((cuirass (cuirass-configuration-cuirass config)) (cache-directory (cuirass-configuration-cache-directory config)) (web-log-file (cuirass-configuration-web-log-file config)) - (log-file (cuirass-configuration-log-file config)) + (main-log-file (cuirass-configuration-log-file config)) (user (cuirass-configuration-user config)) (group (cuirass-configuration-group config)) (interval (cuirass-configuration-interval config)) @@ -169,7 +169,7 @@ (define (cuirass-shepherd-service config) #:user #$user #:group #$group - #:log-file #$log-file)) + #:log-file #$main-log-file)) (stop #~(make-kill-destructor))) ,(shepherd-service (documentation "Run Cuirass web interface.") diff --git a/gnu/services/getmail.scm b/gnu/services/getmail.scm index fb82d054ca..19faea782f 100644 --- a/gnu/services/getmail.scm +++ b/gnu/services/getmail.scm @@ -215,17 +215,6 @@ (define-configuration getmail-options-configuration (parameter-alist '()) "Extra options to include.")) -(define (serialize-getmail-configuration-file field-name val) - (match-record val - (retriever destination options) - #~(string-append - "[retriever]\n" - #$(serialize-getmail-retriever-configuration #f retriever) - "\n[destination]\n" - #$(serialize-getmail-destination-configuration #f destination) - "\n[options]\n" - #$(serialize-getmail-options-configuration #f options)))) - (define-configuration getmail-configuration-file (retriever (getmail-retriever-configuration (getmail-retriever-configuration)) @@ -237,6 +226,17 @@ (define-configuration getmail-configuration-file (getmail-options-configuration (getmail-options-configuration)) "Configure getmail.")) +(define (serialize-getmail-configuration-file field-name val) + (match-record val + (retriever destination options) + #~(string-append + "[retriever]\n" + #$(serialize-getmail-retriever-configuration #f retriever) + "\n[destination]\n" + #$(serialize-getmail-destination-configuration #f destination) + "\n[options]\n" + #$(serialize-getmail-options-configuration #f options)))) + (define (serialize-symbol field-name val) "") (define (serialize-getmail-configuration field-name val) "") diff --git a/guix/records.scm b/guix/records.scm index ed94c83dac..13463647c8 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2012-2022 Ludovic Courtès ;;; Copyright © 2018 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -104,6 +104,10 @@ (define (report-duplicate-field-specifier name ctor) (() #t))))))) +(define-syntax map-fields + (lambda (x) + (syntax-violation 'map-fields "bad use of syntactic keyword" x x))) + (define-syntax-parameter this-record (lambda (s) "Return the record being defined. This macro may only be used in the @@ -325,6 +329,15 @@ (define-record-type* thing make-thing field and its 'loc' field---the latter is marked as \"innate\", so it is not inherited." + (define (rtd-identifier type) + ;; Return an identifier derived from TYPE to name its record type + ;; descriptor (RTD). + (let ((type-name (syntax->datum type))) + (datum->syntax + type + (string->symbol + (string-append "% " (symbol->string type-name) " rtd"))))) + (define (field-default-value s) (syntax-case s (default) ((field (default val) _ ...) @@ -428,10 +441,31 @@ (define (compute-abi-cookie field-specs) field))) field-spec))) #`(begin - (define-record-type type + (define-record-type #,(rtd-identifier #'type) (ctor field ...) pred field-spec* ...) + + ;; Rectify the vtable type name... + (set-struct-vtable-name! #,(rtd-identifier #'type) 'type) + (cond-expand + (guile-3 + ;; ... and the record type name. + (struct-set! #,(rtd-identifier #'type) vtable-offset-user + 'type)) + (else #f)) + + (define-syntax type + (lambda (s) + "This macro lets us query record type info at +macro-expansion time." + (syntax-case s (map-fields) + ((_ map-fields macro) + #'(macro (field ...))) + (id + (identifier? #'id) + #'#,(rtd-identifier #'type))))) + (define #,(current-abi-identifier #'type) #,cookie) @@ -535,19 +569,50 @@ (define (recutils->alist port) (else (error "unmatched line" line)))))))) + +;;; +;;; Pattern matching. +;;; + +(define-syntax lookup-field + (lambda (s) + "Look up FIELD in the given list and return an expression that represents +its offset in the record. Raise a syntax violation when the field is not +found." + (syntax-case s () + ((_ field offset ()) + (syntax-violation 'lookup-field "unknown record type field" + s #'field)) + ((_ field offset (head tail ...)) + (free-identifier=? #'field #'head) + #'offset) + ((_ field offset (_ tail ...)) + #'(lookup-field field (+ 1 offset) (tail ...)))))) + +(define-syntax match-record-inner + (lambda (s) + (syntax-case s () + ((_ record type (field rest ...) body ...) + #`(let-syntax ((field-offset (syntax-rules () + ((_ f) + (lookup-field field 0 f))))) + (let* ((offset (type map-fields field-offset)) + (field (struct-ref record offset))) + (match-record-inner record type (rest ...) body ...)))) + ((_ record type () body ...) + #'(begin body ...))))) + (define-syntax match-record (syntax-rules () "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name. +The order in which fields appear does not matter. A syntax error is raised if +an unknown field is queried. + The current implementation does not support thunked and delayed fields." - ((_ record type (field fields ...) body ...) + ;; TODO support thunked and delayed fields + ((_ record type (fields ...) body ...) (if (eq? (struct-vtable record) type) - ;; TODO compute indices and report wrong-field-name errors at - ;; expansion time - ;; TODO support thunked and delayed fields - (let ((field ((record-accessor type 'field) record))) - (match-record record type (fields ...) body ...)) - (throw 'wrong-type-arg record))) - ((_ record type () body ...) - (begin body ...)))) + (match-record-inner record type (fields ...) body ...) + (throw 'wrong-type-arg record))))) ;;; records.scm ends here diff --git a/tests/records.scm b/tests/records.scm index 00c58b0736..76dadb3d48 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -528,4 +528,37 @@ (define (make-me-a-record) (foo))) '("a" "b" "c") '("a"))) +(test-equal "record-match, simple" + '((1 2) (a b)) + (let () + (define-record-type* foo make-foo + foo? + (first foo-first (default 1)) + (second foo-second)) + + (list (match-record (foo (second 2)) + (first second) + (list first second)) + (match-record (foo (first 'a) (second 'b)) + (second first) + (list first second))))) + +(test-equal "record-match, unknown field" + 'syntax-error + (catch 'syntax-error + (lambda () + (eval '(begin + (use-modules (guix records)) + + (define-record-type* foo make-foo + foo? + (first foo-first (default 1)) + (second foo-second)) + + (match-record (foo (second 2)) + (one two) + #f)) + (make-fresh-user-module))) + (lambda (key . args) key))) + (test-end) From patchwork Sat Nov 19 22:24:51 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 44687 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 1DDC727BBED; Sat, 19 Nov 2022 22:26:28 +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=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2,SPF_HELO_PASS, URIBL_BLOCKED autolearn=ham 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 8507A27BBE9 for ; Sat, 19 Nov 2022 22:26:27 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1owWHu-0007Jy-5w; Sat, 19 Nov 2022 17:26:14 -0500 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 1owWHi-0007JF-Av for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWHi-0004SY-2y for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1owWHh-0004gf-Ud for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:01 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#59390] [PATCH 2/5] doc: Recommend 'match-record'. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 19 Nov 2022 22:26:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 59390 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 59390@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 59390-submit@debbugs.gnu.org id=B59390.166889673117924 (code B ref 59390); Sat, 19 Nov 2022 22:26:01 +0000 Received: (at 59390) by debbugs.gnu.org; 19 Nov 2022 22:25:31 +0000 Received: from localhost ([127.0.0.1]:41583 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWHD-0004f1-53 for submit@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:31 -0500 Received: from eggs.gnu.org ([209.51.188.92]:58074) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWHB-0004ei-RU for 59390@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:30 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1owWH6-0004Je-Ky; Sat, 19 Nov 2022 17:25:24 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=20GcEvWOA08GTJKOhrNIiaAgeo7tfeOB7qBBrezc5Hg=; b=R0HWUUH+aD4Sv6k0Lf+4 3Q1gepytSsYCmspEyXKJOGAjrwf04rvFNzPlzComeqqOcUdwJQ7HsoIiVZ7a9Cys9Yo5luzZrmHcG q9ibJYVTw/m+Pe+FDnTRGIpdIgq9/+YUPyTgYMBHzyg6brngTMyOuVjLtYAZ2Wr9wBSK1zgGXUs88 trtyNj/hTgvVC6Jg/BaJEzO+2M3kc/T/Grv2NNi9gc6VYu2UGAGCadjqE8z18nkFSgIC64ohKd3XB dhAfiddw/3ZZdqGWlujkePJ1No1Rujz6cm2gCmJffoL4SdUPqM40akkt+BeVvFbXJy2mtSsHFrwv8 cRcd5Zh4LqWk6Q==; Received: from 91-160-117-201.subs.proxad.net ([91.160.117.201] helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWGk-0006LD-Td; Sat, 19 Nov 2022 17:25:03 -0500 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sat, 19 Nov 2022 23:24:51 +0100 Message-Id: <20221119222454.10759-2-ludo@gnu.org> X-Mailer: git-send-email 2.38.1 In-Reply-To: <20221119222454.10759-1-ludo@gnu.org> References: <20221119222454.10759-1-ludo@gnu.org> 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-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * doc/contributing.texi (Data Types and Pattern Matching): Recommend 'match-record'. --- doc/contributing.texi | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/doc/contributing.texi b/doc/contributing.texi index 40ae33ecac..6a8ffd6524 100644 --- a/doc/contributing.texi +++ b/doc/contributing.texi @@ -1089,11 +1089,16 @@ and then to browse them ``by hand'' using @code{car}, @code{cdr}, notably the fact that it is hard to read, error-prone, and a hindrance to proper type error reports. +@findex define-record-type* +@findex match-record +@cindex pattern matching Guix code should define appropriate data types (for instance, using @code{define-record-type*}) rather than abuse lists. In addition, it should use pattern matching, via Guile’s @code{(ice-9 match)} module, especially when matching lists (@pxref{Pattern Matching,,, guile, GNU -Guile Reference Manual}). +Guile Reference Manual}); pattern matching for records is better done +using @code{match-record} from @code{(guix records)}, which, unlike +@code{match}, verifies field names at macro-expansion time. @node Formatting Code @subsection Formatting Code From patchwork Sat Nov 19 22:24:52 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 44686 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 0F12627BBE9; Sat, 19 Nov 2022 22:26:23 +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=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2,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 AA38827BBEC for ; Sat, 19 Nov 2022 22:26:19 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1owWHt-0007Jw-SP; Sat, 19 Nov 2022 17:26:14 -0500 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 1owWHi-0007JL-R2 for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWHi-0004Sg-Hj for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1owWHi-0004gn-Dm for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#59390] [PATCH 3/5] home: services: Use 'match-record' instead of 'match'. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 19 Nov 2022 22:26:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 59390 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 59390@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 59390-submit@debbugs.gnu.org id=B59390.166889673617946 (code B ref 59390); Sat, 19 Nov 2022 22:26:02 +0000 Received: (at 59390) by debbugs.gnu.org; 19 Nov 2022 22:25:36 +0000 Received: from localhost ([127.0.0.1]:41587 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWHH-0004fK-Ep for submit@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:36 -0500 Received: from eggs.gnu.org ([209.51.188.92]:50488) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWHD-0004el-QB for 59390@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:32 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1owWH8-0004K6-Jr; Sat, 19 Nov 2022 17:25:26 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=Zl19JcKxO72wC4CJcR5ByWaBh4SEj1DQoKQAx/S8nVA=; b=S6hfTVvPxqv9XvNiuvfN xN1p6DcZN8eIypKUTlYwZntwRNm59Y9zP5e2TMqjUnxuyiQWIev+QVbjgPc8qLInjM2bJcgLUIQqL VI2zwHs6LmGJjV7ivGkOfAUB5x2E5SAYaStnh2z+sBE/Whe9W/xlPFBJPksx9ZJXF4N93B6ympU3+ MgRI3chJUpsT+NM9hiQn8BPNpQwv6dZAnboIlfKc4kpcy8YFLIpz935fk2a/oRqF9Z7NcXl6El4wV VOC2lRHhE0k9Az18iPFPa5ji3wUzYLw4/RjxjxxR6cetaWGj22XkP7chdUYHwilwWs8y07sFCUolM cPhx9+fLJ22ueQ==; Received: from 91-160-117-201.subs.proxad.net ([91.160.117.201] helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWH5-0006LD-Vo; Sat, 19 Nov 2022 17:25:25 -0500 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sat, 19 Nov 2022 23:24:52 +0100 Message-Id: <20221119222454.10759-3-ludo@gnu.org> X-Mailer: git-send-email 2.38.1 In-Reply-To: <20221119222454.10759-1-ludo@gnu.org> References: <20221119222454.10759-1-ludo@gnu.org> 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-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/home/services/mcron.scm (home-mcron-shepherd-services): Use 'match-record' instead of 'match'. * gnu/home/services/shells.scm (home-bash-extensions): Likewise. * gnu/home/services/xdg.scm (serialize-xdg-desktop-entry): Likewise. --- gnu/home/services/mcron.scm | 58 ++++++++++++++++++------------------ gnu/home/services/shells.scm | 50 +++++++++++++++---------------- gnu/home/services/xdg.scm | 36 +++++++++++----------- 3 files changed, 72 insertions(+), 72 deletions(-) diff --git a/gnu/home/services/mcron.scm b/gnu/home/services/mcron.scm index 1d294a997c..5f35bfe054 100644 --- a/gnu/home/services/mcron.scm +++ b/gnu/home/services/mcron.scm @@ -77,35 +77,35 @@ (define job-files (@@ (gnu services mcron) job-files)) (define shepherd-schedule-action (@@ (gnu services mcron) shepherd-schedule-action)) -(define home-mcron-shepherd-services - (match-lambda - (($ mcron '()) ; no jobs to run - '()) - (($ mcron jobs log? log-format) - (let ((files (job-files mcron jobs))) - (list (shepherd-service - (documentation "User cron jobs.") - (provision '(mcron)) - (modules `((srfi srfi-1) - (srfi srfi-26) - (ice-9 popen) ; for the 'schedule' action - (ice-9 rdelim) - (ice-9 match) - ,@%default-modules)) - (start #~(make-forkexec-constructor - (list (string-append #$mcron "/bin/mcron") - #$@(if log? - #~("--log" "--log-format" #$log-format) - #~()) - #$@files) - #:log-file (string-append - (or (getenv "XDG_LOG_HOME") - (format #f "~a/.local/var/log" - (getenv "HOME"))) - "/mcron.log"))) - (stop #~(make-kill-destructor)) - (actions - (list (shepherd-schedule-action mcron files))))))))) +(define (home-mcron-shepherd-services config) + (match-record config + (mcron jobs log? log-format) + (if (null? jobs) + '() ;no jobs to run + (let ((files (job-files mcron jobs))) + (list (shepherd-service + (documentation "User cron jobs.") + (provision '(mcron)) + (modules `((srfi srfi-1) + (srfi srfi-26) + (ice-9 popen) ;for the 'schedule' action + (ice-9 rdelim) + (ice-9 match) + ,@%default-modules)) + (start #~(make-forkexec-constructor + (list (string-append #$mcron "/bin/mcron") + #$@(if log? + #~("--log" "--log-format" #$log-format) + #~()) + #$@files) + #:log-file (string-append + (or (getenv "XDG_LOG_HOME") + (format #f "~a/.local/var/log" + (getenv "HOME"))) + "/mcron.log"))) + (stop #~(make-kill-destructor)) + (actions + (list (shepherd-schedule-action mcron files))))))))) (define home-mcron-profile (compose list home-mcron-configuration-mcron)) diff --git a/gnu/home/services/shells.scm b/gnu/home/services/shells.scm index 3e346c3813..b529c8e798 100644 --- a/gnu/home/services/shells.scm +++ b/gnu/home/services/shells.scm @@ -25,6 +25,7 @@ (define-module (gnu home services shells) #:use-module (gnu packages bash) #:use-module (guix gexp) #:use-module (guix packages) + #:use-module (guix records) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) @@ -479,31 +480,30 @@ (define-configuration/no-serialization home-bash-extension with text blocks from other extensions and the base service.")) (define (home-bash-extensions original-config extension-configs) - (match original-config - (($ _ _ environment-variables aliases - bash-profile bashrc bash-logout) - (home-bash-configuration - (inherit original-config) - (environment-variables - (append environment-variables - (append-map - home-bash-extension-environment-variables extension-configs))) - (aliases - (append aliases - (append-map - home-bash-extension-aliases extension-configs))) - (bash-profile - (append bash-profile - (append-map - home-bash-extension-bash-profile extension-configs))) - (bashrc - (append bashrc - (append-map - home-bash-extension-bashrc extension-configs))) - (bash-logout - (append bash-logout - (append-map - home-bash-extension-bash-logout extension-configs))))))) + (match-record original-config + (environment-variables aliases bash-profile bashrc bash-logout) + (home-bash-configuration + (inherit original-config) + (environment-variables + (append environment-variables + (append-map + home-bash-extension-environment-variables extension-configs))) + (aliases + (append aliases + (append-map + home-bash-extension-aliases extension-configs))) + (bash-profile + (append bash-profile + (append-map + home-bash-extension-bash-profile extension-configs))) + (bashrc + (append bashrc + (append-map + home-bash-extension-bashrc extension-configs))) + (bash-logout + (append bash-logout + (append-map + home-bash-extension-bash-logout extension-configs)))))) (define home-bash-service-type (service-type (name 'home-bash) diff --git a/gnu/home/services/xdg.scm b/gnu/home/services/xdg.scm index 63c6041cd4..3c6cb773ad 100644 --- a/gnu/home/services/xdg.scm +++ b/gnu/home/services/xdg.scm @@ -383,25 +383,25 @@ (define (format-config key val) (define (serialize-alist config) (generic-serialize-alist append format-config config)) - (define (serialize-xdg-desktop-action action) - (match action - (($ action name config) - `(,(format #f "[Desktop Action ~a]\n" - (string-capitalize (maybe-object->string action))) - ,(format #f "Name=~a\n" name) - ,@(serialize-alist config))))) + (define (serialize-xdg-desktop-action desktop-action) + (match-record desktop-action + (action name config) + `(,(format #f "[Desktop Action ~a]\n" + (string-capitalize (maybe-object->string action))) + ,(format #f "Name=~a\n" name) + ,@(serialize-alist config)))) - (match entry - (($ file name type config actions) - (list (if (string-suffix? file ".desktop") - file - (string-append file ".desktop")) - `("[Desktop Entry]\n" - ,(format #f "Name=~a\n" name) - ,(format #f "Type=~a\n" - (string-capitalize (symbol->string type))) - ,@(serialize-alist config) - ,@(append-map serialize-xdg-desktop-action actions)))))) + (match-record entry + (file name type config actions) + (list (if (string-suffix? file ".desktop") + file + (string-append file ".desktop")) + `("[Desktop Entry]\n" + ,(format #f "Name=~a\n" name) + ,(format #f "Type=~a\n" + (string-capitalize (symbol->string type))) + ,@(serialize-alist config) + ,@(append-map serialize-xdg-desktop-action actions))))) (define-configuration home-xdg-mime-applications-configuration (added From patchwork Sat Nov 19 22:24:53 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 44689 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 9CEAB27BBEC; Sat, 19 Nov 2022 22:26:54 +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=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2,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 1B10327BBE9 for ; Sat, 19 Nov 2022 22:26:50 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1owWHv-0007Kl-O4; Sat, 19 Nov 2022 17:26:15 -0500 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 1owWHj-0007JW-7h for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWHi-0004Sm-Vj for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1owWHi-0004gu-SO for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#59390] [PATCH 4/5] services: base: Use 'match-record' instead of 'match'. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 19 Nov 2022 22:26:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 59390 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 59390@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 59390-submit@debbugs.gnu.org id=B59390.166889674117973 (code B ref 59390); Sat, 19 Nov 2022 22:26:02 +0000 Received: (at 59390) by debbugs.gnu.org; 19 Nov 2022 22:25:41 +0000 Received: from localhost ([127.0.0.1]:41593 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWHL-0004ff-A9 for submit@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:41 -0500 Received: from eggs.gnu.org ([209.51.188.92]:50500) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWHI-0004f9-PC for 59390@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:38 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1owWHD-0004Kj-IK; Sat, 19 Nov 2022 17:25:31 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=qnDgNzopOcg49212QIEQXFWq1aJxFMrTFU1ASZXKavI=; b=npJapGhA14hay1ZpZnn4 PV4BtGOnPt0pmuir4S5gy79CKryMGbQfuSr5yRo0Pmoz0BSVI287TS6E05wZqo2cNlV6Fitgtetju ynzzTn4U320knXvTA41oe52x8CKWB6pz8r0mELXrydkd4xCgerLutixcUGhhSgobGGiAEgVptI+ly V016kHzDClvCqnNx/s9bo/Y0daFOror1PuqE1jluUFzB4xq7HZ8uQW/Xtlk9S1RB09xz4tGF5tash bgn7hEQfed4DvsZ92Y6uCVJDwF8RKyLWN8yHj7DLTZf3y0ZCzEO166tOHCfRAZYzi/X72vwCgbOlq wWC8MyPJ0i1kgg==; Received: from 91-160-117-201.subs.proxad.net ([91.160.117.201] helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWH8-0006LD-Qq; Sat, 19 Nov 2022 17:25:30 -0500 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sat, 19 Nov 2022 23:24:53 +0100 Message-Id: <20221119222454.10759-4-ludo@gnu.org> X-Mailer: git-send-email 2.38.1 In-Reply-To: <20221119222454.10759-1-ludo@gnu.org> References: <20221119222454.10759-1-ludo@gnu.org> 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-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/services/base.scm (agetty-shepherd-service) (mingetty-shepherd-service) (nscd.conf-file) (udev-shepherd-service) (udev-etc) (gpm-shepherd-service) (network-set-up/linux) (network-tear-down/linux) (static-networking-shepherd-service) (greetd-agreety-tty-session-command) (greetd-agreety-tty-xdg-session-command): Use 'match-record' instead of 'match'. (guix-accounts): Use accessors. (udev-service-type): Use accessors. --- gnu/services/base.scm | 882 +++++++++++++++++++++--------------------- 1 file changed, 440 insertions(+), 442 deletions(-) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index d99548573d..370696a55e 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -977,148 +977,148 @@ (define (default-serial-port) ((device-name _ ...) device-name)))))))) -(define agetty-shepherd-service - (match-lambda - (($ agetty tty term baud-rate auto-login - login-program login-pause? eight-bits? no-reset? remote? flow-control? - host no-issue? init-string no-clear? local-line extract-baud? - skip-login? no-newline? login-options chroot hangup? keep-baud? timeout - detect-case? wait-cr? no-hints? no-hostname? long-hostname? - erase-characters kill-characters chdir delay nice extra-options - shepherd-requirement) - (list - (shepherd-service - (documentation "Run agetty on a tty.") - (provision (list (symbol-append 'term- (string->symbol (or tty "console"))))) +(define (agetty-shepherd-service config) + (match-record config + (agetty tty term baud-rate auto-login + login-program login-pause? eight-bits? no-reset? remote? flow-control? + host no-issue? init-string no-clear? local-line extract-baud? + skip-login? no-newline? login-options chroot hangup? keep-baud? timeout + detect-case? wait-cr? no-hints? no-hostname? long-hostname? + erase-characters kill-characters chdir delay nice extra-options + shepherd-requirement) + (list + (shepherd-service + (documentation "Run agetty on a tty.") + (provision (list (symbol-append 'term- (string->symbol (or tty "console"))))) - ;; Since the login prompt shows the host name, wait for the 'host-name' - ;; service to be done. Also wait for udev essentially so that the tty - ;; text is not lost in the middle of kernel messages (see also - ;; mingetty-shepherd-service). - (requirement (cons* 'user-processes 'host-name 'udev - shepherd-requirement)) + ;; Since the login prompt shows the host name, wait for the 'host-name' + ;; service to be done. Also wait for udev essentially so that the tty + ;; text is not lost in the middle of kernel messages (see also + ;; mingetty-shepherd-service). + (requirement (cons* 'user-processes 'host-name 'udev + shepherd-requirement)) - (modules '((ice-9 match) (gnu build linux-boot))) - (start - (with-imported-modules (source-module-closure - '((gnu build linux-boot))) - #~(lambda args - (let ((defaulted-tty #$(or tty (default-serial-port)))) - (apply - (if defaulted-tty - (make-forkexec-constructor - (list #$(file-append util-linux "/sbin/agetty") - #$@extra-options - #$@(if eight-bits? - #~("--8bits") - #~()) - #$@(if no-reset? - #~("--noreset") - #~()) - #$@(if remote? - #~("--remote") - #~()) - #$@(if flow-control? - #~("--flow-control") - #~()) - #$@(if host - #~("--host" #$host) - #~()) - #$@(if no-issue? - #~("--noissue") - #~()) - #$@(if init-string - #~("--init-string" #$init-string) - #~()) - #$@(if no-clear? - #~("--noclear") - #~()) + (modules '((ice-9 match) (gnu build linux-boot))) + (start + (with-imported-modules (source-module-closure + '((gnu build linux-boot))) + #~(lambda args + (let ((defaulted-tty #$(or tty (default-serial-port)))) + (apply + (if defaulted-tty + (make-forkexec-constructor + (list #$(file-append util-linux "/sbin/agetty") + #$@extra-options + #$@(if eight-bits? + #~("--8bits") + #~()) + #$@(if no-reset? + #~("--noreset") + #~()) + #$@(if remote? + #~("--remote") + #~()) + #$@(if flow-control? + #~("--flow-control") + #~()) + #$@(if host + #~("--host" #$host) + #~()) + #$@(if no-issue? + #~("--noissue") + #~()) + #$@(if init-string + #~("--init-string" #$init-string) + #~()) + #$@(if no-clear? + #~("--noclear") + #~()) ;;; FIXME This doesn't work as expected. According to agetty(8), if this option ;;; is not passed, then the default is 'auto'. However, in my tests, when that ;;; option is selected, agetty never presents the login prompt, and the ;;; term-ttyS0 service respawns every few seconds. - #$@(if local-line - #~(#$(match local-line - ('auto "--local-line=auto") - ('always "--local-line=always") - ('never "-local-line=never"))) - #~()) - #$@(if tty - #~() - #~("--keep-baud")) - #$@(if extract-baud? - #~("--extract-baud") - #~()) - #$@(if skip-login? - #~("--skip-login") - #~()) - #$@(if no-newline? - #~("--nonewline") - #~()) - #$@(if login-options - #~("--login-options" #$login-options) - #~()) - #$@(if chroot - #~("--chroot" #$chroot) - #~()) - #$@(if hangup? - #~("--hangup") - #~()) - #$@(if keep-baud? - #~("--keep-baud") - #~()) - #$@(if timeout - #~("--timeout" #$(number->string timeout)) - #~()) - #$@(if detect-case? - #~("--detect-case") - #~()) - #$@(if wait-cr? - #~("--wait-cr") - #~()) - #$@(if no-hints? - #~("--nohints?") - #~()) - #$@(if no-hostname? - #~("--nohostname") - #~()) - #$@(if long-hostname? - #~("--long-hostname") - #~()) - #$@(if erase-characters - #~("--erase-chars" #$erase-characters) - #~()) - #$@(if kill-characters - #~("--kill-chars" #$kill-characters) - #~()) - #$@(if chdir - #~("--chdir" #$chdir) - #~()) - #$@(if delay - #~("--delay" #$(number->string delay)) - #~()) - #$@(if nice - #~("--nice" #$(number->string nice)) - #~()) - #$@(if auto-login - (list "--autologin" auto-login) - '()) - #$@(if login-program - #~("--login-program" #$login-program) - #~()) - #$@(if login-pause? - #~("--login-pause") - #~()) - defaulted-tty - #$@(if baud-rate - #~(#$baud-rate) - #~()) - #$@(if term - #~(#$term) - #~()))) - (const #f)) ; never start. - args))))) - (stop #~(make-kill-destructor))))))) + #$@(if local-line + #~(#$(match local-line + ('auto "--local-line=auto") + ('always "--local-line=always") + ('never "-local-line=never"))) + #~()) + #$@(if tty + #~() + #~("--keep-baud")) + #$@(if extract-baud? + #~("--extract-baud") + #~()) + #$@(if skip-login? + #~("--skip-login") + #~()) + #$@(if no-newline? + #~("--nonewline") + #~()) + #$@(if login-options + #~("--login-options" #$login-options) + #~()) + #$@(if chroot + #~("--chroot" #$chroot) + #~()) + #$@(if hangup? + #~("--hangup") + #~()) + #$@(if keep-baud? + #~("--keep-baud") + #~()) + #$@(if timeout + #~("--timeout" #$(number->string timeout)) + #~()) + #$@(if detect-case? + #~("--detect-case") + #~()) + #$@(if wait-cr? + #~("--wait-cr") + #~()) + #$@(if no-hints? + #~("--nohints?") + #~()) + #$@(if no-hostname? + #~("--nohostname") + #~()) + #$@(if long-hostname? + #~("--long-hostname") + #~()) + #$@(if erase-characters + #~("--erase-chars" #$erase-characters) + #~()) + #$@(if kill-characters + #~("--kill-chars" #$kill-characters) + #~()) + #$@(if chdir + #~("--chdir" #$chdir) + #~()) + #$@(if delay + #~("--delay" #$(number->string delay)) + #~()) + #$@(if nice + #~("--nice" #$(number->string nice)) + #~()) + #$@(if auto-login + (list "--autologin" auto-login) + '()) + #$@(if login-program + #~("--login-program" #$login-program) + #~()) + #$@(if login-pause? + #~("--login-pause") + #~()) + defaulted-tty + #$@(if baud-rate + #~(#$baud-rate) + #~()) + #$@(if term + #~(#$term) + #~()))) + (const #f)) ; never start. + args))))) + (stop #~(make-kill-destructor)))))) (define agetty-service-type (service-type (name 'agetty) @@ -1148,42 +1148,42 @@ (define-record-type* (clear-on-logout? mingetty-clear-on-logout? ;Boolean (default #t))) -(define mingetty-shepherd-service - (match-lambda - (($ mingetty tty auto-login login-program - login-pause? clear-on-logout?) - (list - (shepherd-service - (documentation "Run mingetty on an tty.") - (provision (list (symbol-append 'term- (string->symbol tty)))) +(define (mingetty-shepherd-service config) + (match-record config + (mingetty tty auto-login login-program + login-pause? clear-on-logout?) + (list + (shepherd-service + (documentation "Run mingetty on an tty.") + (provision (list (symbol-append 'term- (string->symbol tty)))) - ;; Since the login prompt shows the host name, wait for the 'host-name' - ;; service to be done. Also wait for udev essentially so that the tty - ;; text is not lost in the middle of kernel messages (XXX). - (requirement '(user-processes host-name udev virtual-terminal)) + ;; Since the login prompt shows the host name, wait for the 'host-name' + ;; service to be done. Also wait for udev essentially so that the tty + ;; text is not lost in the middle of kernel messages (XXX). + (requirement '(user-processes host-name udev virtual-terminal)) - (start #~(make-forkexec-constructor - (list #$(file-append mingetty "/sbin/mingetty") + (start #~(make-forkexec-constructor + (list #$(file-append mingetty "/sbin/mingetty") - ;; Avoiding 'vhangup' allows us to avoid 'setfont' - ;; errors down the path where various ioctls get - ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c - ;; in Linux. - "--nohangup" #$tty + ;; Avoiding 'vhangup' allows us to avoid 'setfont' + ;; errors down the path where various ioctls get + ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c + ;; in Linux. + "--nohangup" #$tty - #$@(if clear-on-logout? - #~() - #~("--noclear")) - #$@(if auto-login - #~("--autologin" #$auto-login) - #~()) - #$@(if login-program - #~("--loginprog" #$login-program) - #~()) - #$@(if login-pause? - #~("--loginpause") - #~())))) - (stop #~(make-kill-destructor))))))) + #$@(if clear-on-logout? + #~() + #~("--noclear")) + #$@(if auto-login + #~("--autologin" #$auto-login) + #~()) + #$@(if login-program + #~("--loginprog" #$login-program) + #~()) + #$@(if login-pause? + #~("--loginpause") + #~())))) + (stop #~(make-kill-destructor)))))) (define mingetty-service-type (service-type (name 'mingetty) @@ -1260,46 +1260,47 @@ (define %nscd-default-configuration (define (nscd.conf-file config) "Return the @file{nscd.conf} configuration file for @var{config}, an @code{} object." - (define cache->config - (match-lambda - (($ (= symbol->string database) - positive-ttl negative-ttl size check-files? - persistent? shared? max-size propagate?) - (string-append "\nenable-cache\t" database "\tyes\n" + (define (cache->config cache) + (match-record cache + (database positive-time-to-live negative-time-to-live + suggested-size check-files? + persistent? shared? max-database-size auto-propagate?) + (let ((database (symbol->string database))) + (string-append "\nenable-cache\t" database "\tyes\n" - "positive-time-to-live\t" database "\t" - (number->string positive-ttl) "\n" - "negative-time-to-live\t" database "\t" - (number->string negative-ttl) "\n" - "suggested-size\t" database "\t" - (number->string size) "\n" - "check-files\t" database "\t" - (if check-files? "yes\n" "no\n") - "persistent\t" database "\t" - (if persistent? "yes\n" "no\n") - "shared\t" database "\t" - (if shared? "yes\n" "no\n") - "max-db-size\t" database "\t" - (number->string max-size) "\n" - "auto-propagate\t" database "\t" - (if propagate? "yes\n" "no\n"))))) + "positive-time-to-live\t" database "\t" + (number->string positive-time-to-live) "\n" + "negative-time-to-live\t" database "\t" + (number->string negative-time-to-live) "\n" + "suggested-size\t" database "\t" + (number->string suggested-size) "\n" + "check-files\t" database "\t" + (if check-files? "yes\n" "no\n") + "persistent\t" database "\t" + (if persistent? "yes\n" "no\n") + "shared\t" database "\t" + (if shared? "yes\n" "no\n") + "max-db-size\t" database "\t" + (number->string max-database-size) "\n" + "auto-propagate\t" database "\t" + (if auto-propagate? "yes\n" "no\n"))))) - (match config - (($ log-file debug-level caches) - (plain-file "nscd.conf" - (string-append "\ + (match-record config + (log-file debug-level caches) + (plain-file "nscd.conf" + (string-append "\ # Configuration of libc's name service cache daemon (nscd).\n\n" - (if log-file - (string-append "logfile\t" log-file) - "") - "\n" - (if debug-level - (string-append "debug-level\t" - (number->string debug-level)) - "") - "\n" - (string-concatenate - (map cache->config caches))))))) + (if log-file + (string-append "logfile\t" log-file) + "") + "\n" + (if debug-level + (string-append "debug-level\t" + (number->string debug-level)) + "") + "\n" + (string-concatenate + (map cache->config caches)))))) (define (nscd-action-procedure nscd config option) ;; XXX: This is duplicated from mcron; factorize. @@ -1797,17 +1798,15 @@ (define discover? (define (guix-accounts config) "Return the user accounts and user groups for CONFIG." - (match config - (($ _ build-group build-accounts) - (cons (user-group - (name build-group) - (system? #t) + (cons (user-group + (name (guix-configuration-build-group config)) + (system? #t) - ;; Use a fixed GID so that we can create the store with the right - ;; owner. - (id 30000)) - (guix-build-accounts build-accounts - #:group build-group))))) + ;; Use a fixed GID so that we can create the store with the right + ;; owner. + (id 30000)) + (guix-build-accounts (guix-configuration-build-accounts config) + #:group (guix-configuration-build-group config)))) (define (guix-activation config) "Return the activation gexp for CONFIG." @@ -2130,95 +2129,94 @@ (define kvm-udev-rule (udev-rule "90-kvm.rules" "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n")) -(define udev-shepherd-service +(define (udev-shepherd-service config) ;; Return a for UDEV with RULES. - (match-lambda - (($ udev) - (list - (shepherd-service - (provision '(udev)) + (let ((udev (udev-configuration-udev config))) + (list + (shepherd-service + (provision '(udev)) - ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can - ;; be added: see - ;; . - (requirement '(root-file-system)) + ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can + ;; be added: see + ;; . + (requirement '(root-file-system)) - (documentation "Populate the /dev directory, dynamically.") - (start - (with-imported-modules (source-module-closure - '((gnu build linux-boot))) - #~(lambda () - (define udevd - ;; 'udevd' from eudev. - #$(file-append udev "/sbin/udevd")) + (documentation "Populate the /dev directory, dynamically.") + (start + (with-imported-modules (source-module-closure + '((gnu build linux-boot))) + #~(lambda () + (define udevd + ;; 'udevd' from eudev. + #$(file-append udev "/sbin/udevd")) - (define (wait-for-udevd) - ;; Wait until someone's listening on udevd's control - ;; socket. - (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) - (let try () - (catch 'system-error - (lambda () - (connect sock PF_UNIX "/run/udev/control") - (close-port sock)) - (lambda args - (format #t "waiting for udevd...~%") - (usleep 500000) - (try)))))) + (define (wait-for-udevd) + ;; Wait until someone's listening on udevd's control + ;; socket. + (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) + (let try () + (catch 'system-error + (lambda () + (connect sock PF_UNIX "/run/udev/control") + (close-port sock)) + (lambda args + (format #t "waiting for udevd...~%") + (usleep 500000) + (try)))))) - ;; Allow udev to find the modules. - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") + ;; Allow udev to find the modules. + (setenv "LINUX_MODULE_DIRECTORY" + "/run/booted-system/kernel/lib/modules") - (let* ((kernel-release - (utsname:release (uname))) - (linux-module-directory - (getenv "LINUX_MODULE_DIRECTORY")) - (directory - (string-append linux-module-directory "/" - kernel-release)) - (old-umask (umask #o022))) - ;; If we're in a container, DIRECTORY might not exist, - ;; for instance because the host runs a different - ;; kernel. In that case, skip it; we'll just miss a few - ;; nodes like /dev/fuse. - (when (file-exists? directory) - (make-static-device-nodes directory)) - (umask old-umask)) + (let* ((kernel-release + (utsname:release (uname))) + (linux-module-directory + (getenv "LINUX_MODULE_DIRECTORY")) + (directory + (string-append linux-module-directory "/" + kernel-release)) + (old-umask (umask #o022))) + ;; If we're in a container, DIRECTORY might not exist, + ;; for instance because the host runs a different + ;; kernel. In that case, skip it; we'll just miss a few + ;; nodes like /dev/fuse. + (when (file-exists? directory) + (make-static-device-nodes directory)) + (umask old-umask)) - (let ((pid (fork+exec-command - (list udevd) - #:environment-variables - (cons* - ;; The first one is for udev, the second one for - ;; eudev. - "UDEV_CONFIG_FILE=/etc/udev/udev.conf" - "EUDEV_RULES_DIRECTORY=/etc/udev/rules.d" - (string-append "LINUX_MODULE_DIRECTORY=" - (getenv "LINUX_MODULE_DIRECTORY")) - (default-environment-variables))))) - ;; Wait until udevd is up and running. This appears to - ;; be needed so that the events triggered below are - ;; actually handled. - (wait-for-udevd) + (let ((pid (fork+exec-command + (list udevd) + #:environment-variables + (cons* + ;; The first one is for udev, the second one for + ;; eudev. + "UDEV_CONFIG_FILE=/etc/udev/udev.conf" + "EUDEV_RULES_DIRECTORY=/etc/udev/rules.d" + (string-append "LINUX_MODULE_DIRECTORY=" + (getenv "LINUX_MODULE_DIRECTORY")) + (default-environment-variables))))) + ;; Wait until udevd is up and running. This appears to + ;; be needed so that the events triggered below are + ;; actually handled. + (wait-for-udevd) - ;; Trigger device node creation. - (system* #$(file-append udev "/bin/udevadm") - "trigger" "--action=add") + ;; Trigger device node creation. + (system* #$(file-append udev "/bin/udevadm") + "trigger" "--action=add") - ;; Wait for things to settle down. - (system* #$(file-append udev "/bin/udevadm") - "settle") - pid)))) - (stop #~(make-kill-destructor)) + ;; Wait for things to settle down. + (system* #$(file-append udev "/bin/udevadm") + "settle") + pid)))) + (stop #~(make-kill-destructor)) - ;; When halting the system, 'udev' is actually killed by - ;; 'user-processes', i.e., before its own 'stop' method was called. - ;; Thus, make sure it is not respawned. - (respawn? #f) - ;; We need additional modules. - (modules `((gnu build linux-boot) ;'make-static-device-nodes' - ,@%default-modules))))))) + ;; When halting the system, 'udev' is actually killed by + ;; 'user-processes', i.e., before its own 'stop' method was called. + ;; Thus, make sure it is not respawned. + (respawn? #f) + ;; We need additional modules. + (modules `((gnu build linux-boot) ;'make-static-device-nodes' + ,@%default-modules)))))) (define udev.conf (computed-file "udev.conf" @@ -2226,14 +2224,15 @@ (define udev.conf (lambda (port) (format port "udev_rules=\"/etc/udev/rules.d\"~%"))))) -(define udev-etc - (match-lambda - (($ udev rules) - `(("udev" - ,(file-union - "udev" `(("udev.conf" ,udev.conf) - ("rules.d" ,(udev-rules-union (cons* udev kvm-udev-rule - rules)))))))))) +(define (udev-etc config) + (match-record config + (udev rules) + `(("udev" + ,(file-union "udev" + `(("udev.conf" ,udev.conf) + ("rules.d" + ,(udev-rules-union (cons* udev kvm-udev-rule + rules))))))))) (define udev-service-type (service-type (name 'udev) @@ -2243,11 +2242,11 @@ (define udev-service-type (service-extension etc-service-type udev-etc))) (compose concatenate) ;concatenate the list of rules (extend (lambda (config rules) - (match config - (($ udev initial-rules) - (udev-configuration - (udev udev) - (rules (append initial-rules rules))))))) + (let ((initial-rules + (udev-configuration-rules config))) + (udev-configuration + (inherit config) + (rules (append initial-rules rules)))))) (default-value (udev-configuration)) (description "Run @command{udev}, which populates the @file{/dev} @@ -2385,23 +2384,23 @@ (define-record-type* (options gpm-configuration-options ;list of strings (default %default-gpm-options))) -(define gpm-shepherd-service - (match-lambda - (($ gpm options) - (list (shepherd-service - (requirement '(udev)) - (provision '(gpm)) - ;; 'gpm' runs in the background and sets a PID file. - ;; Note that it requires running as "root". - (start #~(make-forkexec-constructor - (list #$(file-append gpm "/sbin/gpm") - #$@options) - #:pid-file "/var/run/gpm.pid" - #:pid-file-timeout 3)) - (stop #~(lambda (_) - ;; Return #f if successfully stopped. - (not (zero? (system* #$(file-append gpm "/sbin/gpm") - "-k")))))))))) +(define (gpm-shepherd-service config) + (match-record config + (gpm options) + (list (shepherd-service + (requirement '(udev)) + (provision '(gpm)) + ;; 'gpm' runs in the background and sets a PID file. + ;; Note that it requires running as "root". + (start #~(make-forkexec-constructor + (list #$(file-append gpm "/sbin/gpm") + #$@options) + #:pid-file "/var/run/gpm.pid" + #:pid-file-timeout 3)) + (stop #~(lambda (_) + ;; Return #f if successfully stopped. + (not (zero? (system* #$(file-append gpm "/sbin/gpm") + "-k"))))))))) (define gpm-service-type (service-type (name 'gpm) @@ -2654,32 +2653,64 @@ (define (network-tear-down/hurd config) "/servers/socket/2") #f)))) -(define network-set-up/linux - (match-lambda - (($ addresses links routes) - (scheme-file "set-up-network" - (with-extensions (list guile-netlink) - #~(begin - (use-modules (ip addr) (ip link) (ip route)) +(define (network-set-up/linux config) + (match-record config + (addresses links routes) + (scheme-file "set-up-network" + (with-extensions (list guile-netlink) + #~(begin + (use-modules (ip addr) (ip link) (ip route)) - #$@(map (lambda (address) - #~(begin - (addr-add #$(network-address-device address) - #$(network-address-value address) - #:ipv6? - #$(network-address-ipv6? address)) - ;; FIXME: loopback? - (link-set #$(network-address-device address) - #:multicast-on #t - #:up #t))) - addresses) - #$@(map (match-lambda - (($ name type arguments) - #~(link-add #$name #$type - #:type-args '#$arguments))) - links) - #$@(map (lambda (route) - #~(route-add #$(network-route-destination route) + #$@(map (lambda (address) + #~(begin + (addr-add #$(network-address-device address) + #$(network-address-value address) + #:ipv6? + #$(network-address-ipv6? address)) + ;; FIXME: loopback? + (link-set #$(network-address-device address) + #:multicast-on #t + #:up #t))) + addresses) + #$@(map (match-lambda + (($ name type arguments) + #~(link-add #$name #$type + #:type-args '#$arguments))) + links) + #$@(map (lambda (route) + #~(route-add #$(network-route-destination route) + #:device + #$(network-route-device route) + #:ipv6? + #$(network-route-ipv6? route) + #:via + #$(network-route-gateway route) + #:src + #$(network-route-source route))) + routes) + #t))))) + +(define (network-tear-down/linux config) + (match-record config + (addresses links routes) + (scheme-file "tear-down-network" + (with-extensions (list guile-netlink) + #~(begin + (use-modules (ip addr) (ip link) (ip route) + (netlink error) + (srfi srfi-34)) + + (define-syntax-rule (false-if-netlink-error exp) + (guard (c ((netlink-error? c) #f)) + exp)) + + ;; Wrap calls in 'false-if-netlink-error' so this + ;; script goes as far as possible undoing the effects + ;; of "set-up-network". + + #$@(map (lambda (route) + #~(false-if-netlink-error + (route-del #$(network-route-destination route) #:device #$(network-route-device route) #:ipv6? @@ -2687,80 +2718,47 @@ (define network-set-up/linux #:via #$(network-route-gateway route) #:src - #$(network-route-source route))) - routes) - #t)))))) - -(define network-tear-down/linux - (match-lambda - (($ addresses links routes) - (scheme-file "tear-down-network" - (with-extensions (list guile-netlink) - #~(begin - (use-modules (ip addr) (ip link) (ip route) - (netlink error) - (srfi srfi-34)) - - (define-syntax-rule (false-if-netlink-error exp) - (guard (c ((netlink-error? c) #f)) - exp)) - - ;; Wrap calls in 'false-if-netlink-error' so this - ;; script goes as far as possible undoing the effects - ;; of "set-up-network". - - #$@(map (lambda (route) + #$(network-route-source route)))) + routes) + #$@(map (match-lambda + (($ name type arguments) #~(false-if-netlink-error - (route-del #$(network-route-destination route) - #:device - #$(network-route-device route) - #:ipv6? - #$(network-route-ipv6? route) - #:via - #$(network-route-gateway route) - #:src - #$(network-route-source route)))) - routes) - #$@(map (match-lambda - (($ name type arguments) - #~(false-if-netlink-error - (link-del #$name)))) - links) - #$@(map (lambda (address) - #~(false-if-netlink-error - (addr-del #$(network-address-device - address) - #$(network-address-value address) - #:ipv6? - #$(network-address-ipv6? address)))) - addresses) - #f)))))) + (link-del #$name)))) + links) + #$@(map (lambda (address) + #~(false-if-netlink-error + (addr-del #$(network-address-device + address) + #$(network-address-value address) + #:ipv6? + #$(network-address-ipv6? address)))) + addresses) + #f))))) (define (static-networking-shepherd-service config) - (match config - (($ addresses links routes - provision requirement name-servers) - (let ((loopback? (and provision (memq 'loopback provision)))) - (shepherd-service + (match-record config + (addresses links routes provision requirement name-servers) + (let ((loopback? (and provision (memq 'loopback provision)))) + (shepherd-service - (documentation - "Bring up the networking interface using a static IP address.") - (requirement requirement) - (provision provision) + (documentation + "Bring up the networking interface using a static IP address.") + (requirement requirement) + (provision provision) - (start #~(lambda _ - ;; Return #t if successfully started. - (load #$(let-system (system target) - (if (string-contains (or target system) "-linux") - (network-set-up/linux config) - (network-set-up/hurd config)))))) - (stop #~(lambda _ - ;; Return #f is successfully stopped. + (start #~(lambda _ + ;; Return #t if successfully started. (load #$(let-system (system target) (if (string-contains (or target system) "-linux") - (network-tear-down/linux config) - (network-tear-down/hurd config)))))) - (respawn? #f)))))) + (network-set-up/linux config) + (network-set-up/hurd config)))))) + (stop #~(lambda _ + ;; Return #f is successfully stopped. + (load #$(let-system (system target) + (if (string-contains (or target system) "-linux") + (network-tear-down/linux config) + (network-tear-down/hurd config)))))) + (respawn? #f))))) (define (static-networking-shepherd-services networks) (map static-networking-shepherd-service networks)) @@ -2873,33 +2871,33 @@ (define-record-type* (extra-env greetd-agreety-extra-env (default '())) (xdg-env? greetd-agreety-xdg-env? (default #t))) -(define greetd-agreety-tty-session-command - (match-lambda - (($ _ command args extra-env) - (program-file - "agreety-tty-session-command" - #~(begin - (use-modules (ice-9 match)) - (for-each (match-lambda ((var . val) (setenv var val))) - (quote (#$@extra-env))) - (apply execl #$command #$command (list #$@args))))))) +(define (greetd-agreety-tty-session-command config) + (match-record config + (command command-args extra-env) + (program-file + "agreety-tty-session-command" + #~(begin + (use-modules (ice-9 match)) + (for-each (match-lambda ((var . val) (setenv var val))) + (quote (#$@extra-env))) + (apply execl #$command #$command (list #$@command-args)))))) -(define greetd-agreety-tty-xdg-session-command - (match-lambda - (($ _ command args extra-env) - (program-file - "agreety-tty-xdg-session-command" - #~(begin - (use-modules (ice-9 match)) - (let* - ((username (getenv "USER")) - (useruid (passwd:uid (getpwuid username))) - (useruid (number->string useruid))) - (setenv "XDG_SESSION_TYPE" "tty") - (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid))) - (for-each (match-lambda ((var . val) (setenv var val))) - (quote (#$@extra-env))) - (apply execl #$command #$command (list #$@args))))))) +(define (greetd-agreety-tty-xdg-session-command config) + (match-record config + (command command-args extra-env) + (program-file + "agreety-tty-xdg-session-command" + #~(begin + (use-modules (ice-9 match)) + (let* + ((username (getenv "USER")) + (useruid (passwd:uid (getpwuid username))) + (useruid (number->string useruid))) + (setenv "XDG_SESSION_TYPE" "tty") + (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid))) + (for-each (match-lambda ((var . val) (setenv var val))) + (quote (#$@extra-env))) + (apply execl #$command #$command (list #$@command-args)))))) (define-gexp-compiler (greetd-agreety-session-compiler (session ) From patchwork Sat Nov 19 22:24:54 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 44688 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 8478227BBEC; Sat, 19 Nov 2022 22:26:32 +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=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2,SPF_HELO_PASS, URIBL_BLOCKED autolearn=ham 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 8202C27BBE9 for ; Sat, 19 Nov 2022 22:26:28 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1owWHw-0007LE-Ha; Sat, 19 Nov 2022 17:26:16 -0500 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 1owWHj-0007Jr-S3 for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:04 -0500 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWHj-0004Sw-Cn for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:03 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1owWHj-0004h1-8y for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:03 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#59390] [PATCH 5/5] services: networking: Avoid 'match' on records. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 19 Nov 2022 22:26:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 59390 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 59390@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 59390-submit@debbugs.gnu.org id=B59390.166889674417983 (code B ref 59390); Sat, 19 Nov 2022 22:26:03 +0000 Received: (at 59390) by debbugs.gnu.org; 19 Nov 2022 22:25:44 +0000 Received: from localhost ([127.0.0.1]:41595 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWHP-0004fx-5m for submit@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:44 -0500 Received: from eggs.gnu.org ([209.51.188.92]:50508) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWHJ-0004fG-RI for 59390@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:39 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1owWHE-0004Kw-Kw; Sat, 19 Nov 2022 17:25:32 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=y+lM6rHtL2znr+Kaz1pTsVqaFIcwAVG5/SaibPBMQmE=; b=V7DHjEXexqZC6BnwRoaS xVw7quaecs7vVCFOUSwtHl/cpYbF2MukU/gFMPSfVgcyJ0Sw0TGAC2Xg8OFOdKlg/s0MM0+OryTEu 9gtX+sqT4gGghglZV2Mq00gqeFSFgf/+nDYmm9DY5rl3525/U54tCEgUGHtLhnG3Lp6rnxQfU+cwJ LHNUNOjC3TkNo2nsqIkqP6GqTlq13T4APaWJ1RBDoeVeVTkO9UthjPH83Zr57qL9g3tjBj3+zHlCj sIsEKvK6Ge6Y45VWGW011JT3+k7mh7fVVUbxTizhNau2nBJobGFJJtr7arUgZjYctMSnVHqEzqDKX j6F18i+S3gN8lw==; Received: from 91-160-117-201.subs.proxad.net ([91.160.117.201] helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWHD-0006LD-Ok; Sat, 19 Nov 2022 17:25:32 -0500 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sat, 19 Nov 2022 23:24:54 +0100 Message-Id: <20221119222454.10759-5-ludo@gnu.org> X-Mailer: git-send-email 2.38.1 In-Reply-To: <20221119222454.10759-1-ludo@gnu.org> References: <20221119222454.10759-1-ludo@gnu.org> 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-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/services/networking.scm (dhcp-client-shepherd-service): Use accessors instead of 'match'. (inetd-shepherd-service): Likewise. (tor-shepherd-service): Likewise. (network-manager-service-type): Likewise. (modem-manager-service-type): Likewise. (wpa-supplicant-service-type): Likewise. (openvswitch-activation): Likewise. (openvswitch-shepherd-service): Likewise. (dhcpd-shepherd-service): Use 'match-record' instead of 'match'. (dhcpd-activation): Likewise. (ntp-server->string): Likewise. (ntp-shepherd-service): Likewise. (tor-configuration->torrc): Likewise. (network-manager-activation): Likewise. (network-manager-environment): Likewise. (network-manager-shepherd-service): Likewise. (usb-modeswitch-configuration->udev-rules): Likewise. (wpa-supplicant-shepherd-service): Likewise. (iptables-shepherd-service): Likewise. (nftables-shepherd-service): Likewise. (keepalived-shepherd-service): Likewise. --- gnu/services/networking.scm | 661 ++++++++++++++++++------------------ 1 file changed, 327 insertions(+), 334 deletions(-) diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index de02f16a34..4f5af1beb0 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -277,8 +277,10 @@ (define-record-type* (define dhcp-client-shepherd-service (match-lambda - (($ package interfaces) - (let ((pid-file "/var/run/dhclient.pid")) + ((? dhcp-client-configuration? config) + (let ((package (dhcp-client-configuration-package config)) + (interfaces (dhcp-client-configuration-interfaces config)) + (pid-file "/var/run/dhclient.pid")) (list (shepherd-service (documentation "Set up networking via DHCP.") (requirement '(user-processes udev)) @@ -359,46 +361,46 @@ (define-record-type* (interfaces dhcpd-configuration-interfaces (default '()))) -(define dhcpd-shepherd-service - (match-lambda - (($ package config-file version run-directory - lease-file pid-file interfaces) - (unless config-file - (error "Must supply a config-file")) - (list (shepherd-service - ;; Allow users to easily run multiple versions simultaneously. - (provision (list (string->symbol - (string-append "dhcpv" version "-daemon")))) - (documentation (string-append "Run the DHCPv" version " daemon")) - (requirement '(networking)) - (start #~(make-forkexec-constructor - '(#$(file-append package "/sbin/dhcpd") - #$(string-append "-" version) - "-lf" #$lease-file - "-pf" #$pid-file - "-cf" #$config-file - #$@interfaces) - #:pid-file #$pid-file)) - (stop #~(make-kill-destructor))))))) +(define (dhcpd-shepherd-service config) + (match-record config + (package config-file version run-directory + lease-file pid-file interfaces) + (unless config-file + (error "Must supply a config-file")) + (list (shepherd-service + ;; Allow users to easily run multiple versions simultaneously. + (provision (list (string->symbol + (string-append "dhcpv" version "-daemon")))) + (documentation (string-append "Run the DHCPv" version " daemon")) + (requirement '(networking)) + (start #~(make-forkexec-constructor + '(#$(file-append package "/sbin/dhcpd") + #$(string-append "-" version) + "-lf" #$lease-file + "-pf" #$pid-file + "-cf" #$config-file + #$@interfaces) + #:pid-file #$pid-file)) + (stop #~(make-kill-destructor)))))) -(define dhcpd-activation - (match-lambda - (($ package config-file version run-directory - lease-file pid-file interfaces) - (with-imported-modules '((guix build utils)) - #~(begin - (unless (file-exists? #$run-directory) - (mkdir #$run-directory)) - ;; According to the DHCP manual (man dhcpd.leases), the lease - ;; database must be present for dhcpd to start successfully. - (unless (file-exists? #$lease-file) - (with-output-to-file #$lease-file - (lambda _ (display "")))) - ;; Validate the config. - (invoke/quiet - #$(file-append package "/sbin/dhcpd") - #$(string-append "-" version) - "-t" "-cf" #$config-file)))))) +(define (dhcpd-activation config) + (match-record config + (package config-file version run-directory + lease-file pid-file interfaces) + (with-imported-modules '((guix build utils)) + #~(begin + (unless (file-exists? #$run-directory) + (mkdir #$run-directory)) + ;; According to the DHCP manual (man dhcpd.leases), the lease + ;; database must be present for dhcpd to start successfully. + (unless (file-exists? #$lease-file) + (with-output-to-file #$lease-file + (lambda _ (display "")))) + ;; Validate the config. + (invoke/quiet + #$(file-append package "/sbin/dhcpd") + #$(string-append "-" version) + "-t" "-cf" #$config-file))))) (define dhcpd-service-type (service-type @@ -449,16 +451,16 @@ (define (flatten lst) (fold loop res x) (cons (format #f "~a" x) res))))) - (match ntp-server - (($ type address options) - ;; XXX: It'd be neater if fields were validated at the syntax level (for - ;; static ones at least). Perhaps the Guix record type could support a - ;; predicate property on a field? - (unless (enum-set-member? type ntp-server-types) - (error "Invalid NTP server type" type)) - (string-join (cons* (symbol->string type) - address - (flatten options)))))) + (match-record ntp-server + (type address options) + ;; XXX: It'd be neater if fields were validated at the syntax level (for + ;; static ones at least). Perhaps the Guix record type could support a + ;; predicate property on a field? + (unless (enum-set-member? type ntp-server-types) + (error "Invalid NTP server type" type)) + (string-join (cons* (symbol->string type) + address + (flatten options))))) (define %ntp-servers ;; Default set of NTP servers. These URLs are managed by the NTP Pool project. @@ -497,17 +499,16 @@ (define (ntp-configuration-servers ntp-configuration) ((($ ) ($ ) ...) ntp-servers)))) -(define ntp-shepherd-service - (lambda (config) - (match config - (($ ntp servers allow-large-adjustment?) - (let ((servers (ntp-configuration-servers config))) - ;; TODO: Add authentication support. - (define config - (string-append "driftfile /var/run/ntpd/ntp.drift\n" - (string-join (map ntp-server->string servers) - "\n") - " +(define (ntp-shepherd-service config) + (match-record config + (ntp servers allow-large-adjustment?) + (let ((servers (ntp-configuration-servers config))) + ;; TODO: Add authentication support. + (define config + (string-append "driftfile /var/run/ntpd/ntp.drift\n" + (string-join (map ntp-server->string servers) + "\n") + " # Disable status queries as a workaround for CVE-2013-5211: # . restrict default kod nomodify notrap nopeer noquery limited @@ -521,21 +522,21 @@ (define config # option by default, as documented in the 'ntp.conf' manual. restrict source notrap nomodify noquery\n")) - (define ntpd.conf - (plain-file "ntpd.conf" config)) + (define ntpd.conf + (plain-file "ntpd.conf" config)) - (list (shepherd-service - (provision '(ntpd)) - (documentation "Run the Network Time Protocol (NTP) daemon.") - (requirement '(user-processes networking)) - (start #~(make-forkexec-constructor - (list (string-append #$ntp "/bin/ntpd") "-n" - "-c" #$ntpd.conf "-u" "ntpd" - #$@(if allow-large-adjustment? - '("-g") - '())) - #:log-file "/var/log/ntpd.log")) - (stop #~(make-kill-destructor))))))))) + (list (shepherd-service + (provision '(ntpd)) + (documentation "Run the Network Time Protocol (NTP) daemon.") + (requirement '(user-processes networking)) + (start #~(make-forkexec-constructor + (list (string-append #$ntp "/bin/ntpd") "-n" + "-c" #$ntpd.conf "-u" "ntpd" + #$@(if allow-large-adjustment? + '("-g") + '())) + #:log-file "/var/log/ntpd.log")) + (stop #~(make-kill-destructor))))))) (define %ntp-accounts (list (user-account @@ -742,19 +743,19 @@ (define (inetd-config-file entries) " ") "\n"))) entries))) -(define inetd-shepherd-service - (match-lambda - (($ program ()) '()) ; empty list of entries -> do nothing - (($ program entries) - (list - (shepherd-service - (documentation "Run inetd.") - (provision '(inetd)) - (requirement '(user-processes networking syslogd)) - (start #~(make-forkexec-constructor - (list #$program #$(inetd-config-file entries)) - #:pid-file "/var/run/inetd.pid")) - (stop #~(make-kill-destructor))))))) +(define (inetd-shepherd-service config) + (let ((entries (inetd-configuration-entries config))) + (if (null? entries) + '() ;do nothing + (let ((program (inetd-configuration-program config))) + (list (shepherd-service + (documentation "Run inetd.") + (provision '(inetd)) + (requirement '(user-processes networking syslogd)) + (start #~(make-forkexec-constructor + (list #$program #$(inetd-config-file entries)) + #:pid-file "/var/run/inetd.pid")) + (stop #~(make-kill-destructor)))))))) (define-public inetd-service-type (service-type @@ -938,97 +939,94 @@ (define-record-type (define (tor-configuration->torrc config) "Return a 'torrc' file for CONFIG." - (match config - (($ tor config-file services - socks-socket-type control-socket?) - (computed-file - "torrc" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 match)) + (match-record config + (tor config-file hidden-services socks-socket-type control-socket?) + (computed-file + "torrc" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) - (call-with-output-file #$output - (lambda (port) - (display "\ + (call-with-output-file #$output + (lambda (port) + (display "\ ### These lines were generated from your system configuration: DataDirectory /var/lib/tor Log notice syslog\n" port) - (when (eq? 'unix '#$socks-socket-type) - (display "\ + (when (eq? 'unix '#$socks-socket-type) + (display "\ SocksPort unix:/var/run/tor/socks-sock UnixSocksGroupWritable 1\n" port)) - (when #$control-socket? - (display "\ + (when #$control-socket? + (display "\ ControlSocket unix:/var/run/tor/control-sock GroupWritable RelaxDirModeCheck ControlSocketsGroupWritable 1\n" - port)) + port)) - (for-each (match-lambda - ((service (ports hosts) ...) - (format port "\ + (for-each (match-lambda + ((service (ports hosts) ...) + (format port "\ HiddenServiceDir /var/lib/tor/hidden-services/~a~%" - service) - (for-each (lambda (tcp-port host) - (format port "\ + service) + (for-each (lambda (tcp-port host) + (format port "\ HiddenServicePort ~a ~a~%" - tcp-port host)) - ports hosts))) - '#$(map (match-lambda - (($ name mapping) - (cons name mapping))) - services)) + tcp-port host)) + ports hosts))) + '#$(map (match-lambda + (($ name mapping) + (cons name mapping))) + hidden-services)) - (display "\ + (display "\ ### End of automatically generated lines.\n\n" port) - ;; Append the user's config file. - (call-with-input-file #$config-file - (lambda (input) - (dump-port input port))) - #t)))))))) + ;; Append the user's config file. + (call-with-input-file #$config-file + (lambda (input) + (dump-port input port))) + #t))))))) (define (tor-shepherd-service config) "Return a running Tor." - (match config - (($ tor) - (let* ((torrc (tor-configuration->torrc config)) - (tor (least-authority-wrapper - (file-append tor "/bin/tor") - #:name "tor" - #:mappings (list (file-system-mapping - (source "/var/lib/tor") - (target source) - (writable? #t)) - (file-system-mapping - (source "/dev/log") ;for syslog - (target source)) - (file-system-mapping - (source "/var/run/tor") - (target source) - (writable? #t)) - (file-system-mapping - (source torrc) - (target source))) - #:namespaces (delq 'net %namespaces)))) - (list (shepherd-service - (provision '(tor)) + (let* ((torrc (tor-configuration->torrc config)) + (tor (least-authority-wrapper + (file-append (tor-configuration-tor config) "/bin/tor") + #:name "tor" + #:mappings (list (file-system-mapping + (source "/var/lib/tor") + (target source) + (writable? #t)) + (file-system-mapping + (source "/dev/log") ;for syslog + (target source)) + (file-system-mapping + (source "/var/run/tor") + (target source) + (writable? #t)) + (file-system-mapping + (source torrc) + (target source))) + #:namespaces (delq 'net %namespaces)))) + (list (shepherd-service + (provision '(tor)) - ;; Tor needs at least one network interface to be up, hence the - ;; dependency on 'loopback'. - (requirement '(user-processes loopback syslogd)) + ;; Tor needs at least one network interface to be up, hence the + ;; dependency on 'loopback'. + (requirement '(user-processes loopback syslogd)) - ;; XXX: #:pid-file won't work because the wrapped 'tor' - ;; program would print its PID within the user namespace - ;; instead of its actual PID outside. There's no inetd or - ;; systemd socket activation support either (there's - ;; 'sd_notify' though), so we're stuck with that. - (start #~(make-forkexec-constructor - (list #$tor "-f" #$torrc) - #:user "tor" #:group "tor")) - (stop #~(make-kill-destructor)) - (actions (list (shepherd-configuration-action torrc))) - (documentation "Run the Tor anonymous network overlay."))))))) + ;; XXX: #:pid-file won't work because the wrapped 'tor' + ;; program would print its PID within the user namespace + ;; instead of its actual PID outside. There's no inetd or + ;; systemd socket activation support either (there's + ;; 'sd_notify' though), so we're stuck with that. + (start #~(make-forkexec-constructor + (list #$tor "-f" #$torrc) + #:user "tor" #:group "tor")) + (stop #~(make-kill-destructor)) + (actions (list (shepherd-configuration-action torrc))) + (documentation "Run the Tor anonymous network overlay."))))) (define (tor-activation config) "Set up directories for Tor and its hidden services, if any." @@ -1145,17 +1143,17 @@ (define-record-type* (vpn-plugins network-manager-configuration-vpn-plugins ;list of file-like (default '()))) -(define network-manager-activation +(define (network-manager-activation config) ;; Activation gexp for NetworkManager - (match-lambda - (($ network-manager dns vpn-plugins) - #~(begin - (use-modules (guix build utils)) - (mkdir-p "/etc/NetworkManager/system-connections") - #$@(if (equal? dns "dnsmasq") - ;; create directory to store dnsmasq lease file - '((mkdir-p "/var/lib/misc")) - '()))))) + (match-record config + (network-manager dns vpn-plugins) + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/etc/NetworkManager/system-connections") + #$@(if (equal? dns "dnsmasq") + ;; create directory to store dnsmasq lease file + '((mkdir-p "/var/lib/misc")) + '())))) (define (vpn-plugin-directory plugins) "Return a directory containing PLUGINS, the NM VPN plugins." @@ -1188,44 +1186,44 @@ (define accounts (cons (user-group (name "network-manager") (system? #t)) accounts)))) -(define network-manager-environment - (match-lambda - (($ network-manager dns vpn-plugins) - ;; Define this variable in the global environment such that - ;; "nmcli connection import type openvpn file foo.ovpn" works. - `(("NM_VPN_PLUGIN_DIR" - . ,(file-append (vpn-plugin-directory vpn-plugins) - "/lib/NetworkManager/VPN")))))) +(define (network-manager-environment config) + (match-record config + (network-manager dns vpn-plugins) + ;; Define this variable in the global environment such that + ;; "nmcli connection import type openvpn file foo.ovpn" works. + `(("NM_VPN_PLUGIN_DIR" + . ,(file-append (vpn-plugin-directory vpn-plugins) + "/lib/NetworkManager/VPN"))))) -(define network-manager-shepherd-service - (match-lambda - (($ network-manager dns vpn-plugins) - (let ((conf (plain-file "NetworkManager.conf" - (string-append "[main]\ndns=" dns "\n"))) - (vpn (vpn-plugin-directory vpn-plugins))) - (list (shepherd-service - (documentation "Run the NetworkManager.") - (provision '(networking)) - (requirement '(user-processes dbus-system wpa-supplicant loopback)) - (start #~(make-forkexec-constructor - (list (string-append #$network-manager - "/sbin/NetworkManager") - (string-append "--config=" #$conf) - "--no-daemon") - #:environment-variables - (list (string-append "NM_VPN_PLUGIN_DIR=" #$vpn - "/lib/NetworkManager/VPN") - ;; Override non-existent default users - "NM_OPENVPN_USER=" - "NM_OPENVPN_GROUP="))) - (stop #~(make-kill-destructor)))))))) +(define (network-manager-shepherd-service config) + (match-record config + (network-manager dns vpn-plugins) + (let ((conf (plain-file "NetworkManager.conf" + (string-append "[main]\ndns=" dns "\n"))) + (vpn (vpn-plugin-directory vpn-plugins))) + (list (shepherd-service + (documentation "Run the NetworkManager.") + (provision '(networking)) + (requirement '(user-processes dbus-system wpa-supplicant loopback)) + (start #~(make-forkexec-constructor + (list (string-append #$network-manager + "/sbin/NetworkManager") + (string-append "--config=" #$conf) + "--no-daemon") + #:environment-variables + (list (string-append "NM_VPN_PLUGIN_DIR=" #$vpn + "/lib/NetworkManager/VPN") + ;; Override non-existent default users + "NM_OPENVPN_USER=" + "NM_OPENVPN_GROUP="))) + (stop #~(make-kill-destructor))))))) (define network-manager-service-type - (let - ((config->packages - (match-lambda - (($ network-manager _ vpn-plugins) - `(,network-manager ,@vpn-plugins))))) + (let ((config->packages + (lambda (config) + (match-record config + (network-manager vpn-plugins) + `(,network-manager ,@vpn-plugins))))) (service-type (name 'network-manager) @@ -1332,9 +1330,8 @@ (define connman-service-type (define modem-manager-service-type (let ((config->package - (match-lambda - (($ modem-manager) - (list modem-manager))))) + (lambda (config) + (list (modem-manager-configuration-modem-manager config))))) (service-type (name 'modem-manager) (extensions (list (service-extension dbus-root-service-type @@ -1405,24 +1402,25 @@ (define (usb-modeswitch-configuration->udev-rules config) usb-modeswitch package specified in CONFIG. The rules file will invoke usb_modeswitch.sh from the usb-modeswitch package, modified to pass the right config file." - (match config - (($ usb-modeswitch data config-file) - (computed-file - "usb_modeswitch.rules" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - (let ((in (string-append #$data "/udev/40-usb_modeswitch.rules")) - (out (string-append #$output "/lib/udev/rules.d")) - (script #$(usb-modeswitch-sh usb-modeswitch config-file))) - (mkdir-p out) - (chdir out) - (install-file in out) - (substitute* "40-usb_modeswitch.rules" - (("PROGRAM=\"usb_modeswitch") - (string-append "PROGRAM=\"" script "/usb_modeswitch")) - (("RUN\\+=\"usb_modeswitch") - (string-append "RUN+=\"" script "/usb_modeswitch")))))))))) + (match-record config + (usb-modeswitch usb-modeswitch-data config-file) + (computed-file + "usb_modeswitch.rules" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (let ((in (string-append #$usb-modeswitch-data + "/udev/40-usb_modeswitch.rules")) + (out (string-append #$output "/lib/udev/rules.d")) + (script #$(usb-modeswitch-sh usb-modeswitch config-file))) + (mkdir-p out) + (chdir out) + (install-file in out) + (substitute* "40-usb_modeswitch.rules" + (("PROGRAM=\"usb_modeswitch") + (string-append "PROGRAM=\"" script "/usb_modeswitch")) + (("RUN\\+=\"usb_modeswitch") + (string-append "RUN+=\"" script "/usb_modeswitch"))))))))) (define usb-modeswitch-service-type (service-type @@ -1466,40 +1464,39 @@ (define-record-type* (extra-options wpa-supplicant-configuration-extra-options ;list of strings (default '()))) -(define wpa-supplicant-shepherd-service - (match-lambda - (($ wpa-supplicant requirement pid-file dbus? - interface config-file extra-options) - (list (shepherd-service - (documentation "Run the WPA supplicant daemon") - (provision '(wpa-supplicant)) - (requirement (if dbus? - (cons 'dbus-system requirement) - requirement)) - (start #~(make-forkexec-constructor - (list (string-append #$wpa-supplicant - "/sbin/wpa_supplicant") - (string-append "-P" #$pid-file) - "-B" ;run in background - "-s" ;log to syslogd - #$@(if dbus? - #~("-u") - #~()) - #$@(if interface - #~((string-append "-i" #$interface)) - #~()) - #$@(if config-file - #~((string-append "-c" #$config-file)) - #~()) - #$@extra-options) - #:pid-file #$pid-file)) - (stop #~(make-kill-destructor))))))) +(define (wpa-supplicant-shepherd-service config) + (match-record config + (wpa-supplicant requirement pid-file dbus? + interface config-file extra-options) + (list (shepherd-service + (documentation "Run the WPA supplicant daemon") + (provision '(wpa-supplicant)) + (requirement (if dbus? + (cons 'dbus-system requirement) + requirement)) + (start #~(make-forkexec-constructor + (list (string-append #$wpa-supplicant + "/sbin/wpa_supplicant") + (string-append "-P" #$pid-file) + "-B" ;run in background + "-s" ;log to syslogd + #$@(if dbus? + #~("-u") + #~()) + #$@(if interface + #~((string-append "-i" #$interface)) + #~()) + #$@(if config-file + #~((string-append "-c" #$config-file)) + #~()) + #$@extra-options) + #:pid-file #$pid-file)) + (stop #~(make-kill-destructor)))))) (define wpa-supplicant-service-type (let ((config->package - (match-lambda - (($ wpa-supplicant) - (list wpa-supplicant))))) + (lambda (config) + (list (wpa-supplicant-configuration-wpa-supplicant config))))) (service-type (name 'wpa-supplicant) (extensions (list (service-extension shepherd-root-service-type @@ -1621,41 +1618,38 @@ (define-record-type* (package openvswitch-configuration-package (default openvswitch))) -(define openvswitch-activation - (match-lambda - (($ package) - (let ((ovsdb-tool (file-append package "/bin/ovsdb-tool"))) - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/run/openvswitch") - (mkdir-p "/var/lib/openvswitch") - (let ((conf.db "/var/lib/openvswitch/conf.db")) - (unless (file-exists? conf.db) - (system* #$ovsdb-tool "create" conf.db))))))))) +(define (openvswitch-activation config) + (let ((ovsdb-tool (file-append (openvswitch-configuration-package config) + "/bin/ovsdb-tool"))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/openvswitch") + (mkdir-p "/var/lib/openvswitch") + (let ((conf.db "/var/lib/openvswitch/conf.db")) + (unless (file-exists? conf.db) + (system* #$ovsdb-tool "create" conf.db))))))) -(define openvswitch-shepherd-service - (match-lambda - (($ package) - (let ((ovsdb-server (file-append package "/sbin/ovsdb-server")) - (ovs-vswitchd (file-append package "/sbin/ovs-vswitchd"))) - (list - (shepherd-service - (provision '(ovsdb)) - (documentation "Run the Open vSwitch database server.") - (start #~(make-forkexec-constructor - (list #$ovsdb-server "--pidfile" - "--remote=punix:/var/run/openvswitch/db.sock") - #:pid-file "/var/run/openvswitch/ovsdb-server.pid")) - (stop #~(make-kill-destructor))) - (shepherd-service - (provision '(vswitchd)) - (requirement '(ovsdb)) - (documentation "Run the Open vSwitch daemon.") - (start #~(make-forkexec-constructor - (list #$ovs-vswitchd "--pidfile") - #:pid-file "/var/run/openvswitch/ovs-vswitchd.pid")) - (stop #~(make-kill-destructor)))))))) +(define (openvswitch-shepherd-service config) + (let* ((package (openvswitch-configuration-package config)) + (ovsdb-server (file-append package "/sbin/ovsdb-server")) + (ovs-vswitchd (file-append package "/sbin/ovs-vswitchd"))) + (list (shepherd-service + (provision '(ovsdb)) + (documentation "Run the Open vSwitch database server.") + (start #~(make-forkexec-constructor + (list #$ovsdb-server "--pidfile" + "--remote=punix:/var/run/openvswitch/db.sock") + #:pid-file "/var/run/openvswitch/ovsdb-server.pid")) + (stop #~(make-kill-destructor))) + (shepherd-service + (provision '(vswitchd)) + (requirement '(ovsdb)) + (documentation "Run the Open vSwitch daemon.") + (start #~(make-forkexec-constructor + (list #$ovs-vswitchd "--pidfile") + #:pid-file "/var/run/openvswitch/ovs-vswitchd.pid")) + (stop #~(make-kill-destructor)))))) (define openvswitch-service-type (service-type @@ -1695,20 +1689,20 @@ (define-record-type* (ipv6-rules iptables-configuration-ipv6-rules (default %iptables-accept-all-rules))) -(define iptables-shepherd-service - (match-lambda - (($ iptables ipv4-rules ipv6-rules) - (let ((iptables-restore (file-append iptables "/sbin/iptables-restore")) - (ip6tables-restore (file-append iptables "/sbin/ip6tables-restore"))) - (shepherd-service - (documentation "Packet filtering framework") - (provision '(iptables)) - (start #~(lambda _ - (invoke #$iptables-restore #$ipv4-rules) - (invoke #$ip6tables-restore #$ipv6-rules))) - (stop #~(lambda _ - (invoke #$iptables-restore #$%iptables-accept-all-rules) - (invoke #$ip6tables-restore #$%iptables-accept-all-rules)))))))) +(define (iptables-shepherd-service config) + (match-record config + (iptables ipv4-rules ipv6-rules) + (let ((iptables-restore (file-append iptables "/sbin/iptables-restore")) + (ip6tables-restore (file-append iptables "/sbin/ip6tables-restore"))) + (shepherd-service + (documentation "Packet filtering framework") + (provision '(iptables)) + (start #~(lambda _ + (invoke #$iptables-restore #$ipv4-rules) + (invoke #$ip6tables-restore #$ipv6-rules))) + (stop #~(lambda _ + (invoke #$iptables-restore #$%iptables-accept-all-rules) + (invoke #$ip6tables-restore #$%iptables-accept-all-rules))))))) (define iptables-service-type (service-type @@ -1767,17 +1761,17 @@ (define-record-type* (ruleset nftables-configuration-ruleset ; file-like object (default %default-nftables-ruleset))) -(define nftables-shepherd-service - (match-lambda - (($ package ruleset) - (let ((nft (file-append package "/sbin/nft"))) - (shepherd-service - (documentation "Packet filtering and classification") - (provision '(nftables)) - (start #~(lambda _ - (invoke #$nft "--file" #$ruleset))) - (stop #~(lambda _ - (invoke #$nft "flush" "ruleset")))))))) +(define (nftables-shepherd-service config) + (match-record config + (package ruleset) + (let ((nft (file-append package "/sbin/nft"))) + (shepherd-service + (documentation "Packet filtering and classification") + (provision '(nftables)) + (start #~(lambda _ + (invoke #$nft "--file" #$ruleset))) + (stop #~(lambda _ + (invoke #$nft "flush" "ruleset"))))))) (define nftables-service-type (service-type @@ -2150,23 +2144,22 @@ (define-record-type* (config-file keepalived-configuration-config-file ;file-like (default #f))) -(define keepalived-shepherd-service - (match-lambda - (($ keepalived config-file) - (list - (shepherd-service - (provision '(keepalived)) - (documentation "Run keepalived.") - (requirement '(loopback)) - (start #~(make-forkexec-constructor - (list (string-append #$keepalived "/sbin/keepalived") - "--dont-fork" "--log-console" "--log-detail" - "--pid=/var/run/keepalived.pid" - (string-append "--use-file=" #$config-file)) - #:pid-file "/var/run/keepalived.pid" - #:log-file "/var/log/keepalived.log")) - (respawn? #f) - (stop #~(make-kill-destructor))))))) +(define (keepalived-shepherd-service config) + (match-record config + (keepalived config-file) + (list (shepherd-service + (provision '(keepalived)) + (documentation "Run keepalived.") + (requirement '(loopback)) + (start #~(make-forkexec-constructor + (list (string-append #$keepalived "/sbin/keepalived") + "--dont-fork" "--log-console" "--log-detail" + "--pid=/var/run/keepalived.pid" + (string-append "--use-file=" #$config-file)) + #:pid-file "/var/run/keepalived.pid" + #:log-file "/var/log/keepalived.log")) + (respawn? #f) + (stop #~(make-kill-destructor)))))) (define %keepalived-log-rotation (list (log-rotation