path: root/install.scm

#!/usr/bin/guile \
-e main -s
!#

(use-modules
 (ice-9 and-let-star)
 (ice-9 format)
 (ice-9 ftw)
 (ice-9 match)
 (ice-9 popen)
 (ice-9 regex)
 (logging logger)
 (logging port-log)
 (oop goops)
 (term ansi-color))

(define-syntax ->>
  (syntax-rules ()
    ((_ value) value)
    ((_ value (f ...) rest ...) (->> (f ... value) rest ...))
    ((_ value f rest ...) (->> (f value) rest ...))))

(define (ansi-color-log-formatter lvl time str)
  (let ((color (case lvl
                 ((CRITICAL) 'RED)
                 ((WARN) 'YELLOW)
                 ((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 (make-dir-parents dir-path)
  (unless (access? dir-path F_OK)
    (make-dir-parents (dirname dir-path))
    (mkdir dir-path)))

(define (dot-replace str)
  (replace str "dot-" "."))

(define (config-links src target dry-run)
  (let ((src-path (expand-file src))
        (target-path (dot-replace (expand-file target))))
    (unless (and (symlink? target-path)
                 (equal? (readlink target-path) src-path))
      (rm-tree target-path dry-run)
      (make-dir-parents (dirname target-path))
      (symlink src-path target-path)
      (log-msg 'OK (string-append "  Symlink " src " <- " target-path)))))

(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 (target-subfile path)
    (->> (substring path src-len)
         (string-append target-path)
         dot-replace
         expand-file))

  (define (enter? name stat result)
    (->> (target-subfile name)
         lstat
         stat:type
         (eq? 'directory)
         false-if-exception))

  (define (leaf name stat result)
    (config-links name (target-subfile name) #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 ((should-clear (->> (scandir (target-subfile name)
                                      (lambda (x)
                                        (not (member x (list "." "..")))))
                             (length)
                             (= (car result)))))
      (when should-clear (leaf name stat result))
      (list-set! result 1 (+ (cadr result) (if should-clear 1 0))))
    (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 (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) "obp")
       "mail/dot-mbsyncrc.byteplant"
       "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@byteplant.com"
           ))
         (user-mail
          (if (string=? (gethostname) "obp")
              "oscar@byteplant.com"
              "hi@oscarnajera.com"))
         ;; setting up notmuch config
         (config
          `((database (path  ,(expand-file "~/.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")
  (symlink-tree "home-dots" "~/")
  (config-links "gnupg/gpg.conf" "~/.gnupg/gpg.conf" #f)
  (config-links "gnupg/gpg-agent.conf" "~/.gnupg/gpg-agent.conf" #f)
  (symlink-tree "config" "~/.config")
  (when (string=? (gethostname) "obp")
    (config-links "other_configs/byte-gitconfig"
                  "~/bytegit/.gitconfig" #f))
  (mail-config)

  (shutdown-logging))