From bf02f467c4c3f4d9fc71aed705986ca8774f5caf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=93scar=20N=C3=A1jera?= Date: Sun, 25 Oct 2020 16:36:25 +0100 Subject: Install a complete tree --- install.scm | 118 ++++++++++++++++++++++++++++++++++++++++++++++-------------- walk.scm | 114 ---------------------------------------------------------- 2 files changed, 92 insertions(+), 140 deletions(-) delete mode 100755 walk.scm diff --git a/install.scm b/install.scm index d5c42d9..57afda3 100755 --- a/install.scm +++ b/install.scm @@ -2,10 +2,11 @@ -e main -s !# (use-modules (ice-9 popen) - (logging logger) - (logging port-log) (ice-9 ftw) (ice-9 match) + (ice-9 and-let-star) + (logging logger) + (logging port-log) (oop goops) (term ansi-color)) @@ -57,43 +58,108 @@ (false-if-exception (eq? 'symlink (stat:type (lstat path))))) -(define (clean-file full-dest) - (when (false-if-exception (lstat full-dest)) - (log-msg 'WARN (string-append "Deleting previous file: " full-dest)) - (delete-file full-dest))) - -(define (config-links src target) +(define (clean-file full-dest dry-run) + (and-let* ((info (false-if-exception (lstat full-dest))) + (type (stat:type info)) + (deleter (if (eq? type 'directory) rmdir delete-file)) + (task (if dry-run "Would delete" "Deleting")) + (level (if dry-run 'INFO 'WARN))) + (log-msg level (format #f "~a ~a: ~a" task type full-dest)) + (unless dry-run (deleter full-dest)))) + +(define (rm-tree path dry-run) + (define (enter? a b c) #t) + (define (down name stat result) result) + (define (leaf name stat result) + (clean-file name dry-run) + result) + (define up leaf) + (define skip leaf) + ;; Ignore unreadable files/directories but warn the user. + (define (error name stat errno result) + (log-msg 'WARN + (format #f "~a: ~a: ~a~%" + errno name (strerror errno))) + result) + + (file-system-fold enter? leaf down up skip error + (list 0) + path)) + +(define (config-links src target dry-run) (let ((src-path (expand-file src)) (target-path (expand-file target))) (unless (and (symlink? target-path) (equal? (readlink target-path) src-path)) - (clean-file target-path) + (clean-file target-path dry-run) (symlink src-path target-path) - (log-msg 'OK (string-append "Symlink" src " -> " target))))) + (log-msg 'OK (string-append " Symlink " src " -> " target))))) + +(define (symlink-tree file-name target-path) + "Tree recursively symlinks target-path->file-name. The goal is to + have few symlinks, yet if in the target space there are some files + then symlink the files not the dir" + + (define src-len (string-length file-name)) + + (define (enter? name stat result) + (let* ((subdir (substring name src-len)) + (target-subdir (expand-file (string-append target-path subdir)))) + (false-if-exception (eq? 'directory (stat:type (lstat target-subdir)))))) + + (define (leaf name stat result) + (let* ((subfile (substring name src-len)) + (target-subfile (string-append target-path subfile))) + (config-links name target-subfile #f)) + + (set-car! result (1+ (car result))) + result) + + (define (down name stat result) + (log-msg 'INFO (format #f "Inspecting ~a" name )) + (cons 0 result)) + (define (up name stat result) + (let* ((subdir (substring name src-len)) + (target-subdir (expand-file (string-append target-path subdir))) + (target-subdir-file-count (length (scandir target-subdir + (lambda (x) + (not (member x (list "." "..")))))))) + ;(format #t " up on ~a ~a ~a ~a ~%" result name target-subdir target-subdir-file-count) + (when (= (car result) target-subdir-file-count) + ;(format #t "~% Clear ~a because is identical to source" name) + (leaf name stat result))) + + (list-set! result 1 (1+ (cadr result))) + (cdr result)) + ;; Likewise for skipped directories. + (define skip leaf) + + ;; Ignore unreadable files/directories but warn the user. + (define (error name stat errno result) + (log-msg 'WARN + (format #f "~a: ~a: ~a~%" + errno name (strerror errno))) + result) + + (file-system-fold enter? leaf down up skip error + (list 0) + file-name)) (define (git-config) (log-msg 'INFO "Configuring git") (log-msg 'INFO " Symlink global config") - (config-links "git/global-gitconfig" "~/.gitconfig") + (config-links "git/global-gitconfig" "~/.gitconfig" #f) (log-msg 'INFO " Symlink Tribe29 config") - (config-links "git/tribe29" "~/git/.gitconfig")) - -(define (symlink-dir dir target-dir) - (let ((cur (getcwd))) - (chdir dir) - (map (lambda (cmd) - (config-links cmd (string-append target-dir cmd))) - (scandir "." (lambda (f) (eq? 'regular (stat:type (stat f)))))) - (chdir cur))) + (config-links "git/tribe29" "~/git/.gitconfig" #f)) (define (main args) (setup-logging) (log-msg 'INFO "Symlink PIM") - (config-links "calendars.conf" "~/.calendars.conf") + (config-links "calendars.conf" "~/.calendars.conf" #f) (git-config) - (config-links "dot-guile" "~/.guile") - (config-links "rofi" "~/.config/rofi") - (config-links "dot-zshrc" "~/.zshrc") - (config-links "gnupu/gpg-agent.conf" "~/.gnupg/gpg-agent") - (symlink-dir "bin" "~/.local/bin/") + (config-links "dot-guile" "~/.guile" #f) + (config-links "dot-zshrc" "~/.zshrc" #f) + (config-links "gnupu/gpg-agent.conf" "~/.gnupg/gpg-agent" #f) + (symlink-tree "bin" "~/.local/bin") + (symlink-tree "config" "~/.config") (shutdown-logging)) diff --git a/walk.scm b/walk.scm deleted file mode 100755 index c244bf3..0000000 --- a/walk.scm +++ /dev/null @@ -1,114 +0,0 @@ -#!/usr/bin/guile \ --s -!# -(use-modules (ice-9 popen) - (logging logger) - (logging port-log) - (ice-9 ftw) - (ice-9 match) - (ice-9 and-let-star) - (oop goops) - (term ansi-color)) - -(define (expand-file f) - ;; https://irreal.org/blog/?p=83 - (cond ((absolute-file-name? f) f) - ((string=? (substring f 0 2) "~/") - (let ((prefix (passwd:dir (getpwuid (geteuid))))) - (string-append prefix (substring f 1 (string-length f))))) - ((char=? (string-ref f 0) #\~) - (let* ((user-end (string-index f #\/)) - (user (substring f 1 user-end)) - (prefix (passwd:dir (getpwnam user)))) - (string-append prefix (substring f user-end (string-length f))))) - (else (string-append (getcwd) "/" f)))) - -(define (symlink? path) - (false-if-exception - (eq? 'symlink (stat:type (lstat path))))) - -(define (clean-file full-dest dry-run) - (and-let* ((info (false-if-exception (lstat full-dest))) - (type (stat:type info)) - (deleter (if (eq? type 'directory) rmdir delete-file)) - (task (if dry-run "Would delete" "Deleting"))) - (format #t "~a ~a: ~a~%" task type full-dest) - (unless dry-run (deleter full-dest)))) - -(define (rm-tree path dry-run) - (define (enter? a b c) #t) - (define (down name stat result) result) - (define (leaf name stat result) - (clean-file name dry-run) - result) - (define up leaf) - (define skip leaf) - ;; Ignore unreadable files/directories but warn the user. - (define (error name stat errno result) - (format (current-error-port) "warning~a: ~a: ~a~%" - errno name (strerror errno)) - result) - - (file-system-fold enter? leaf down up skip error - (list 0) - path)) - -(define (config-links src target dry-run) - (let ((src-path (expand-file src)) - (target-path (expand-file target))) - (unless (and (symlink? target-path) (equal? (readlink target-path) src-path)) - (rm-tree target-path dry-run) - (symlink src-path target-path) - (format #t " Symlink: ~a -> ~a~%" src target)))) - -(define (symlink-tree file-name target-path) - "Tree recursively symlinks target-path->file-name. The goal is to - have few symlinks, yet if in the target space there are some files - then symlink the files not the dir" - - (define src-len (string-length file-name)) - - (define (enter? name stat result) - (let* ((subdir (substring name src-len)) - (target-subdir (string-append target-path subdir))) - (format #t "~a: ~a | ~a ~a~%" name subdir target-subdir (stat:type stat)) - (false-if-exception (eq? 'directory (stat:type (lstat target-subdir)))))) - - (define (leaf name stat result) - (let* ((subfile (substring name src-len)) - (target-subfile (string-append target-path subfile))) - (config-links name target-subfile #f)) - - (set-car! result (1+ (car result))) - result) - - (define (down name stat result) - (cons 0 result)) - (define (up name stat result) - (let* ((subdir (substring name src-len)) - (target-subdir (string-append target-path subdir)) - (target-subdir-file-count (length (scandir target-subdir - (lambda (x) - (not (member x (list "." "..")))))))) - (format #t " up on ~a ~a ~a ~a ~%" result name target-subdir target-subdir-file-count) - (when (= (car result) target-subdir-file-count) - ;(format #t "~% Clear ~a because is identical to source" name) - (leaf name stat result))) - - (list-set! result 1 (1+ (cadr result))) - (cdr result)) - ;; Likewise for skipped directories. - (define skip leaf) - - ;; Ignore unreadable files/directories but warn the user. - (define (error name stat errno result) - (format (current-error-port) "warning: ~a: ~a~%" - name (strerror errno)) - result) - - (file-system-fold enter? leaf down up skip error - (list 0) - file-name)) - - -(symlink-tree "config" "/home/titan/.config") -- cgit v1.2.3