changeset 647: |
74e563ed4537 |
parent: |
35bb0d5ec95e
|
child: |
692dfd7f02d0 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Wed, 11 Sep 2024 21:40:01 -0400 |
permissions: |
-rw-r--r-- |
description: |
cli and rt/fuzz |
1 ;;; homer.lisp --- homectl utility 6 (:use :cl :std :log :sxp :rdb :skel :packy :cli :obj/id :krypt :vc) 7 (:export :main :*home-config*)) 9 (in-package :bin/homer) 10 (defvar *user* (sb-posix:getenv "USER")) 11 (defvar *user-homedir* (user-homedir-pathname)) 12 (defvar *default-user-homerc* (merge-pathnames ".homerc" *user-homedir*)) 13 (declaim (type home-config *home-config*)) 14 (defvar *home-config*) 15 (defvar *home-hidden-paths* (nconc *hidden-paths* (list "stash" "store" "readme.org" ".hgignore"))) 16 (defvar *homer-force* nil) 18 (defun init-homer-vars () 19 (setq *user* (sb-posix:getenv "USER") 20 *user-homedir* (user-homedir-pathname) 21 *default-user-homerc* (merge-pathnames ".homerc" *user-homedir*))) 23 (defclass home-config (sxp id) 24 ((user :initform *user* :initarg :user :type string) 25 (path :initform nil :initarg :path :type (or pathname null)) 26 (src :initform nil :initarg :src :type (or null pathname vc-repo)) 27 (skel :initform (load-user-skelrc) :initarg :skel :type (or null pathname sk-user-config)) 28 (krypt :initform (load-kryptrc) :initarg :krypt :type (or null pathname krypt-config)) 29 (packy :initform nil :initarg :packy :type (or null pathname pk-user-config)) 30 (mail :initarg :mail :type pathname) 31 (term :initform nil :type (or pathname null term-user-config)) 32 (shell :initarg :shell :type (or pathname shell-user-config)) 33 (editor :initarg :editor :type (or pathname editor-user-config)) 34 (wm :initarg :wm :type (or pathname wm-user-config)) 35 (browser :initarg :browser :type (or pathname browser-user-config)))) 37 (defmethod print-object ((self home-config) stream) 38 (print-unreadable-object (self stream :type t) 39 (format stream "~S ~A" :id (format-sxhash (id self))))) 41 (defun find-homer-symbol (s) 42 (find-symbol* (symbol-name s) :homer nil)) 44 (defmethod load-ast ((self home-config)) 45 (with-slots (ast) self 47 ;; ast is valid, modify object, set ast nil 49 (sb-int:doplist (k v) ast 50 (when-let ((s (find-homer-symbol k))) ;; needs to be correct package 51 (setf (slot-value self s) v))) 54 ;; invalid ast, signal error 55 (error 'sxp-syntax-error)))) 58 (defmethod build-ast ((self home-config) &key (nullp nil) (exclude '(ast id))) 66 (defun load-homerc (&optional (file *default-user-homerc*)) 67 "Load a homerc configuration from FILE. Defaults to ~/.homerc." 68 (unless (null (probe-file file)) 69 (let ((form (file-read-forms file))) 70 (setq *home-config* (load-ast (make-instance 'home-config :ast form :path file :id (sxhash form)))) 71 (with-slots (src) *home-config* 73 (setf src (pathname src)) 74 (if-let ((homer (sb-posix:getenv "HOMER"))) 75 (setf src (pathname homer)) 76 (error "missing HOMER directory"))))))) 79 (defopt homer-help (print-help *cli*)) 80 (defopt homer-version (print-version *cli*)) 81 (defopt homer-log-level (when *arg* (setq *log-level* :debug))) 82 (defopt homer-force (when *arg* (setq *homer-force* t))) 85 (describe *home-config*)) 87 (defun mtime (path) (sb-posix:stat-mtime (sb-posix:stat path))) 88 (defun ctime (path) (sb-posix:stat-ctime (sb-posix:stat path))) 90 (defun compare-home-file (src) 91 "Compare a SRC path to what is stored in the user's home. Return a cons with 92 the last modified timestamp of each file (SRC . HOME) or NIL." 93 (let* ((name (enough-namestring src)) 94 (home (merge-pathnames name (user-homedir-pathname))) 96 (m2 (when (probe-file home) (mtime home))) 100 ((< m1 m2) (unless (= (ctime home) m2) 103 (cons status (cons src home)))) 105 (defun homer-status (file) 106 (let ((form (compare-home-file file))) 109 (:new (println (format nil ":NEW ~A" (cdr form)))) 110 (:pull (println (format nil ":PULL ~A" (cadr form)))) 111 (:push (println (format nil ":PUSH ~A" (cddr form)))) 115 (with-slots (src) *home-config* 116 (if-let ((src (probe-file src))) 117 (let ((*default-pathname-defaults* src)) 118 (mapcar #'homer-status 120 *default-pathname-defaults* 121 *home-hidden-paths*))) 122 (error 'file-error :pathname src)))) 124 (defun homer-copy (input output) 125 (ensure-directories-exist output :verbose t) 126 (uiop:copy-file input output)) 128 (defun homer-maybe-push (file) 129 (let ((form (compare-home-file file))) 132 (println (format nil ":PUSH ~A" (cddr form))) 133 (homer-copy (cddr form) (cadr form)))) 136 (defun homer-maybe-pull (file) 137 (let ((form (compare-home-file file))) 140 (println (format nil ":PULL ~A" (cddr form))) 141 (homer-copy (cadr form) (cddr form)))) 144 (defun homer-maybe-install (file) 145 (let ((form (compare-home-file file))) 148 (println (format nil ":PULL ~A" (cddr form))) 149 (homer-copy (cadr form) (cddr form)))) 151 (println (format nil ":NEW ~A" (cddr form))) 152 (homer-copy (cadr form) (cddr form)))) 153 (:push (if *homer-force* 155 (println (format nil ":OVERWRITE ~A" (cddr form))) 156 (homer-copy (cadr form) (cddr form))) 157 (trace! "skipping file:" (cddr form)))) 161 (with-slots (src) *home-config* 162 (if-let ((src (probe-file src))) 163 (let ((*default-pathname-defaults* src)) 164 (mapc #'homer-maybe-push 165 (find-files src *home-hidden-paths*))) 166 (error 'file-error :pathname src)))) 169 (with-slots (src) *home-config* 170 (if-let ((src (probe-file src))) 171 (let ((*default-pathname-defaults* src)) 172 (mapc #'homer-maybe-pull 173 (find-files src *home-hidden-paths*))) 174 (error 'file-error :pathname src)))) 176 (defcmd homer-install 177 (with-slots (src) *home-config* 178 (if-let ((src (probe-file src))) 179 (let ((*default-pathname-defaults* src)) 180 (mapc #'homer-maybe-install 181 (find-files src *home-hidden-paths*))) 182 (error 'file-error :pathname src)))) 187 :description "user home manager" 189 :opts ((:name "level" :global t :description "set the log level" :thunk homer-log-level) 190 (:name "help" :global t :description "print help" :thunk homer-help) 191 (:name "version" :global t :description "print version" :thunk homer-version) 192 (:name "force" :global t :description "use force" :thunk homer-force)) 193 :cmds ((:name show :thunk homer-show) 194 (:name check :thunk homer-check) 195 (:name push :thunk homer-push) 196 (:name pull :thunk homer-pull) 197 (:name install :thunk homer-install))) 200 (let ((*log-level* :info)) 201 (with-cli (opts cmds args) *cli* 205 (debug-opts *cli*)))) 208 (let ((*print-readably* t)) 210 (sb-ext:exit :code 0)))