blob: f56a591b284f82ed3c257deac888efc4876f05fd (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
#!/usr/bin/guile \
-e main -s
!#
(use-modules
(ice-9 and-let-star)
(ice-9 ftw)
(ice-9 match)
(ice-9 popen)
(ice-9 regex)
(logging logger)
(logging port-log)
(oop goops)
(term ansi-color))
(define (ansi-color-log-formatter lvl time str)
(let ((color (cond ((eq? lvl 'CRITICAL) 'RED)
((eq? lvl 'WARN) 'YELLOW)
((eq? lvl 'OK) 'GREEN))))
(string-append
(strftime "%F %H:%M:%S" (localtime time))
(colorize-string
(string-append " (" (symbol->string lvl) "): ") color 'BOLD)
str "\n")))
(define (setup-logging)
(let ((lgr (make <logger>))
(std (make <port-log>
#:port (current-output-port)
#:formatter ansi-color-log-formatter)))
;; add the handler to our logger
(add-handler! lgr std)
;; make this the application's default logger
(set-default-logger! lgr)
(open-log! lgr)))
(define (shutdown-logging)
(flush-log) ;; since no args, it uses the default
(close-log!) ;; since no args, it uses the default
(set-default-logger! #f))
(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"))
(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 (replace str pattern new)
(regexp-substitute/global #f pattern str 'pre new 'post))
(define (config-links src target dry-run)
(let ((src-path (expand-file src))
(target-path (replace (expand-file target) "dot-" ".")))
(unless (and (symlink? target-path) (equal? (readlink target-path) src-path))
(rm-tree target-path dry-run)
(symlink src-path target-path)
(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" #f)
(log-msg 'INFO " Symlink Tribe29 config")
(config-links "git/tribe29" "~/git/.gitconfig" #f))
(define (format-config-entry item)
(format #t "[~a]~%" (car item))
(format #t "~:{~a=~@{~a~^;~}~%~}~%" (cdr item)))
(define (mail-config)
(log-msg 'INFO "Configuring mail")
(log-msg 'INFO " Symlink mbsync")
(config-links (if (string=? (gethostname) "klappbier")
"mail/dot-mbsyncrc.work"
"mail/dot-mbsyncrc.personal")
"~/.mbsyncrc" #f)
(let* ((notmuch-config-file (expand-file "~/.notmuch-config"))
(emails
(list
"hi@oscarnajera.com"
"hello@oscarnajera.com"
"najera.oscar@gmail.com"
"oscar.najera-ocampo@u-psud.fr"
;; Employer related
"oscar.najera@tribe29.com"
"on@mathias-kettner.de"))
(user-mail
(if (string=? (gethostname) "klappbier")
"oscar.najera@tribe29.com"
"hi@oscarnajera.com"))
;; setting up notmuch config
(config
`((database (path ".mail"))
(user (name "Oscar Najera")
(primary_email ,user-mail)
,(cons 'other_email (delete user-mail emails)))
(new (tags new)
(ignore .uidvalidity .mbsyncstate .directory))
(search (exclude_tags deleted spam))
(maildir (synchronize_flags true))
(crypto (gpg_path gpg)))))
(clean-file notmuch-config-file #f)
(with-output-to-file notmuch-config-file
(lambda ()
(display "# -*- mode: conf-unix -*-\n# managed by dotfiles install\n")
(for-each format-config-entry config)))
(chmod notmuch-config-file #o400)))
(define (main args)
(setup-logging)
(log-msg 'INFO "Symlink PIM")
(config-links "calendars.conf" "~/.calendars.conf" #f)
(git-config)
(config-links "dot-guile" "~/.guile" #f)
(config-links "dot-zshrc" "~/.zshrc" #f)
(config-links "dot-inputrc" "~/.inputrc" #f)
(config-links "gnupu/gpg-agent.conf" "~/.gnupg/gpg-agent" #f)
(symlink-tree "bin" "~/.local/bin")
(symlink-tree "config" "~/.config")
(mail-config)
(shutdown-logging))
|
