From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp12.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms0.migadu.com with LMTPS id +AF6E6OEG2IJdQEAgWs5BA (envelope-from ) for ; Sun, 27 Feb 2022 15:03:15 +0100 Received: from aspmx1.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp12.migadu.com with LMTPS id cAH3D6OEG2Lq7QAAauVa8A (envelope-from ) for ; Sun, 27 Feb 2022 15:03:15 +0100 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id C530F4316E for ; Sun, 27 Feb 2022 15:03:14 +0100 (CET) Received: from localhost ([::1]:43228 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1nOK8n-0004yu-V4 for larch@yhetil.org; Sun, 27 Feb 2022 09:03:14 -0500 Received: from eggs.gnu.org ([209.51.188.92]:50704) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nOK10-0000Xg-10 for guix-patches@gnu.org; Sun, 27 Feb 2022 08:55:13 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:35058) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1nOK0w-0001tW-FZ for guix-patches@gnu.org; Sun, 27 Feb 2022 08:55:07 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1nOK0w-0004uh-Eg for guix-patches@gnu.org; Sun, 27 Feb 2022 08:55:06 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#54180] [PATCH 11/12] home: symlink-manager: 'create-symlinks' uses 'file-system-fold'. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sun, 27 Feb 2022 13:55:06 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 54180 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 54180@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 54180-submit@debbugs.gnu.org id=B54180.164597007018761 (code B ref 54180); Sun, 27 Feb 2022 13:55:06 +0000 Received: (at 54180) by debbugs.gnu.org; 27 Feb 2022 13:54:30 +0000 Received: from localhost ([127.0.0.1]:57176 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1nOK0L-0004sQ-QL for submit@debbugs.gnu.org; Sun, 27 Feb 2022 08:54:30 -0500 Received: from eggs.gnu.org ([209.51.188.92]:44874) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1nOK0B-0004qP-FP for 54180@debbugs.gnu.org; Sun, 27 Feb 2022 08:54:21 -0500 Received: from [2001:470:142:3::e] (port=50248 helo=fencepost.gnu.org) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nOK02-0001Zw-LK; Sun, 27 Feb 2022 08:54:11 -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=Wc3wWS4w0MygLoS4JJqop3sbWx6tOsj/j8PiSyRTIq8=; b=QBxoS6gwSTCHqY+wW+7m 08ZunIRutzf1wX8u3LADR2V0p2FM6wMw0Fer0yoJ/hF/92FpXoqynr3t18z46vFqqIY2aVlakma7i Dzu2K1fht+skK+4/EoHiBxMCAaKrwBwlym2hYEpyuXXAi+1bXH7iivgqUZ2EjrLpzURSAKv65OrlR fVyY+mwHsrwgfOVYbrL/nQirMkXUML2ENbJkPCp26C0FYJPBbkCOYW1KzAQAtVY7/YuXCgrzre+eu D07nVRjlKCC17lw6EGwCPgK6YOjNL17sBYLhp/ww0Cc5CvIiI2rBWmMoL2JALjzXs0F1EO/ChcpIz DfdbvRP5MJXFZw==; Received: from 91-160-117-201.subs.proxad.net ([91.160.117.201]:55804 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 1nOK02-0007Pg-5H; Sun, 27 Feb 2022 08:54:10 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sun, 27 Feb 2022 14:53:41 +0100 Message-Id: <20220227135342.10296-11-ludo@gnu.org> X-Mailer: git-send-email 2.34.0 In-Reply-To: <20220227135342.10296-1-ludo@gnu.org> References: <20220227135342.10296-1-ludo@gnu.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Migadu-Flow: FLOW_IN X-Migadu-Country: US ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1645970594; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=Wc3wWS4w0MygLoS4JJqop3sbWx6tOsj/j8PiSyRTIq8=; b=j3BlKLN1CkhT4My2Cwvt4HSu2VhpZcvY6CadXEwC+XgZ/BkUC5sanT4PZtVkLfQjCXH5EZ MW9UznJ4sYqQABHvGNn+0XFRojSB3vSIsZOYbc9Z9XXtFmrkuSreuJEAmbtMvIoFAEyFP3 TwwAjgXCDIDGhf59J6mR0x2omhNGepzX+MO8PxEOPuMt5V8aXW17FhAzXL8OyL0ag//pKo hHK4MbXu6lUDCxZ1gTTcfPQqgI3pLdcm5VHXXOOY1rDZk8s/WNyBZKPIeymUBkp0VRXeVX HdneR1kA1h9tayqzzIVMREylI6UB2f5MC9b6ME2eoakJ6hW+mG/yRpC7m7eObw== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1645970594; a=rsa-sha256; cv=none; b=LD/tZES7edqrD/pKFEIxF6YJiwEsAW8w5CeVNEsMOJ1dhwpUcHRQ9vrki0/hsftYm5OXPl iPWN06jBKm6t26wMb8jY/5GDqOZAzjXbswwXzZTm3eK0AtLOSo2YmmATwliy+1iPBDTmqk WSN6fIfIHeLMwsvROzN6dj66IfDcmqIEa0pK53W/5Lvry573QWNyXZ7BNvmCNlZFkA36Yy BoMJNdpQB3V5gZPRoJ522behQxYLcRycVCPElXs/FpEmyGxiJmwWLmBLv2gWEu9FAp4cDi Ta8J8HmTl1k3BzJVvlkG+sHz/XSAolnxwHZCjmb9bfasAvROiktQDAMbsqX+xA== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=gnu.org header.s=fencepost-gnu-org header.b=QBxoS6gw; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" X-Migadu-Spam-Score: -2.91 Authentication-Results: aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=gnu.org header.s=fencepost-gnu-org header.b=QBxoS6gw; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" X-Migadu-Queue-Id: C530F4316E X-Spam-Score: -2.91 X-Migadu-Scanner: scn0.migadu.com X-TUID: +bIt9byC6sl9 This removes the need for two intermediate representations of the file tree. * gnu/home/services/symlink-manager.scm (update-symlinks-script) [simplify-file-tree, file-tree-traverse]: Remove. [create-symlinks]: Rewrite in terms of 'file-system-fold'. --- gnu/home/services/symlink-manager.scm | 130 +++++++++----------------- 1 file changed, 44 insertions(+), 86 deletions(-) diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm index 4f827c0360..16e2e7b772 100644 --- a/gnu/home/services/symlink-manager.scm +++ b/gnu/home/services/symlink-manager.scm @@ -43,52 +43,11 @@ (define (update-symlinks-script) (guix i18n))) #~(begin (use-modules (ice-9 ftw) - (ice-9 curried-definitions) (ice-9 match) (srfi srfi-1) (guix i18n) (guix build utils)) - (define ((simplify-file-tree parent) file) - "Convert the result produced by `file-system-tree' to less -verbose and more suitable for further processing format. - -Extract dir/file info from stat and compose a relative path to the -root of the file tree. - -Sample output: - -((dir . \".\") - ((dir . \"config\") - ((dir . \"config/fontconfig\") - (file . \"config/fontconfig/fonts.conf\")) - ((dir . \"config/isync\") - (file . \"config/isync/mbsyncrc\")))) -" - (match file - ((name stat) `(file . ,(string-append parent name))) - ((name stat children ...) - (cons `(dir . ,(string-append parent name)) - (map (simplify-file-tree - (if (equal? name ".") - "" - (string-append parent name "/"))) - children))))) - - (define ((file-tree-traverse preordering) node) - "Traverses the file tree in different orders, depending on PREORDERING. - -if PREORDERING is @code{#t} resulting list will contain directories -before files located in those directories, otherwise directory will -appear only after all nested items already listed." - (let ((prepend (lambda (a b) (append b a)))) - (match node - (('file . path) (list node)) - ((('dir . path) . rest) - ((if preordering append prepend) - (list (cons 'dir path)) - (append-map (file-tree-traverse preordering) rest)))))) - (define home-path (getenv "HOME")) @@ -176,64 +135,63 @@ (define (strip file) (display (G_ "Cleanup finished.\n\n"))) - (define (create-symlinks new-tree new-files-path) - ;; Create in directory NEW-TREE symlinks to the files under - ;; NEW-FILES-PATH, creating backups as needed. + (define (create-symlinks home-generation) + ;; Create in $HOME symlinks for the files in HOME-GENERATION. + (define config-file-directory + ;; Note: Trailing slash is needed because "files" is a symlink. + (string-append home-generation "/files/")) + + (define (strip file) + (string-drop file + (+ 1 (string-length config-file-directory)))) + (define (get-source-path path) - (readlink (string-append new-files-path "/" path))) + (readlink (string-append config-file-directory path))) - (let ((to-create ((file-tree-traverse #t) new-tree))) - (for-each - (match-lambda - (('dir . ".") - (display - (G_ "New symlinks to home-environment will be created soon.\n")) - (format - #t (G_ "All conflicting files will go to ~a.\n\n") backup-dir)) + (file-system-fold + (const #t) ;enter? + (lambda (file stat result) ;leaf + (let ((source (get-source-path (strip file))) + (target (get-target-path (strip file)))) + (when (file-exists? target) + (backup-file (strip file))) + (format #t (G_ "Symlinking ~a -> ~a...") + target source) + (symlink source target) + (display (G_ " done\n")))) + (lambda (directory stat result) ;down + (unless (string=? directory config-file-directory) + (let ((target (get-target-path (strip directory)))) + (when (and (file-exists? target) + (not (file-is-directory? target))) + (backup-file (strip directory))) - (('dir . path) - (let ((target-path (get-target-path path))) - (when (and (file-exists? target-path) - (not (file-is-directory? target-path))) - (backup-file path)) - - (if (file-exists? target-path) - (format - #t (G_ "Skipping ~a (directory already exists)... done\n") - target-path) - (begin - (format #t (G_ "Creating ~a...") target-path) - (mkdir target-path) - (display (G_ " done\n")))))) - - (('file . path) - (when (file-exists? (get-target-path path)) - (backup-file path)) - (format #t (G_ "Symlinking ~a -> ~a...") - (get-target-path path) (get-source-path path)) - (symlink (get-source-path path) (get-target-path path)) - (display (G_ " done\n")))) - to-create))) + (catch 'system-error + (lambda () + (mkdir target)) + (lambda args + (let ((errno (system-error-errno args))) + (unless (= EEXIST errno) + (format #t (G_ "failed to create directory ~a: ~s~%") + target (strerror errno)) + (apply throw args)))))))) + (const #t) ;up + (const #t) ;skip + (const #t) ;error + #t ;init + config-file-directory)) #$%initialize-gettext (let* ((he-path (string-append (getenv "HOME") "/.guix-home")) (new-he-path (string-append he-path ".new")) (new-home (getenv "GUIX_NEW_HOME")) - (old-home (getenv "GUIX_OLD_HOME")) - - (new-files-path (string-append new-home "/files")) - ;; Trailing dot is required, because files itself is symlink and - ;; to make file-system-tree works it should be a directory. - (new-files-dir-path (string-append new-files-path "/.")) - - (new-tree ((simplify-file-tree "") - (file-system-tree new-files-dir-path)))) + (old-home (getenv "GUIX_OLD_HOME"))) (when old-home (cleanup-symlinks old-home)) - (create-symlinks new-tree new-files-path) + (create-symlinks new-home) (symlink new-home new-he-path) (rename-file new-he-path he-path) -- 2.34.0