aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorÓscar Nájera <hi@oscarnajera.com>2020-10-25 16:36:25 +0100
committerÓscar Nájera <hi@oscarnajera.com>2020-10-25 16:36:25 +0100
commitbf02f467c4c3f4d9fc71aed705986ca8774f5caf (patch)
tree15b78a6f9b7fd016d0b6ffda7ec29933b746edf1
parentb1bbcaaf3cae88c56a104e3e340b3eb59efd239f (diff)
downloaddotfiles-bf02f467c4c3f4d9fc71aed705986ca8774f5caf.tar.gz
dotfiles-bf02f467c4c3f4d9fc71aed705986ca8774f5caf.tar.bz2
dotfiles-bf02f467c4c3f4d9fc71aed705986ca8774f5caf.zip
Install a complete tree
-rwxr-xr-xinstall.scm118
-rwxr-xr-xwalk.scm114
2 files changed, 92 insertions, 140 deletions
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")