changeset 584: | 35bb0d5ec95e |
parent: | 0de98890711a |
child: | 692dfd7f02d0 |
author: | Richard Westhaver <ellis@rwest.io> |
date: | Sat, 10 Aug 2024 00:30:45 -0400 |
permissions: | -rw-r--r-- |
description: | bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth.. |
96 | 1 | ;;; homer.lisp --- homectl utility |
2 | ||
3 | ;;; Code: |
|
4 | (defpackage :bin/homer |
|
5 | (:nicknames :homer) |
|
342 | 6 | (:use :cl :std :log :sxp :rdb :skel :packy :cli :obj/id :krypt :vc) |
354 | 7 | (:export :main :*home-config*)) |
96 | 8 | |
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*)) |
|
342 | 13 | (declaim (type home-config *home-config*)) |
14 | (defvar *home-config*) |
|
352 | 15 | (defvar *home-hidden-paths* (nconc *hidden-paths* (list "stash" "store" "readme.org" ".hgignore"))) |
355 | 16 | (defvar *homer-force* nil) |
556 | 17 | |
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*))) |
|
22 | |
|
206
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
23 | (defclass home-config (sxp id) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
24 | ((user :initform *user* :initarg :user :type string) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
25 | (path :initform nil :initarg :path :type (or pathname null)) |
569 | 26 | (src :initform nil :initarg :src :type (or null pathname vc-repo)) |
347 | 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)) |
|
342 | 30 | (mail :initarg :mail :type pathname) |
510
607f80be99ca
add term to homer config cuz why not
Richard Westhaver <ellis@rwest.io>
parents:
355
diff
changeset
|
31 | (term :initform nil :type (or pathname null term-user-config)) |
96 | 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)) |
|
342 | 35 | (browser :initarg :browser :type (or pathname browser-user-config)))) |
36 | ||
289
c4682fedd73d
added krypt lib, will probably add homer too
Richard Westhaver <ellis@rwest.io>
parents:
206
diff
changeset
|
37 | (defmethod print-object ((self home-config) stream) |
c4682fedd73d
added krypt lib, will probably add homer too
Richard Westhaver <ellis@rwest.io>
parents:
206
diff
changeset
|
38 | (print-unreadable-object (self stream :type t) |
c4682fedd73d
added krypt lib, will probably add homer too
Richard Westhaver <ellis@rwest.io>
parents:
206
diff
changeset
|
39 | (format stream "~S ~A" :id (format-sxhash (id self))))) |
c4682fedd73d
added krypt lib, will probably add homer too
Richard Westhaver <ellis@rwest.io>
parents:
206
diff
changeset
|
40 | |
206
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
41 | (defun find-homer-symbol (s) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
42 | (find-symbol* (symbol-name s) :homer nil)) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
43 | |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
44 | (defmethod load-ast ((self home-config)) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
45 | (with-slots (ast) self |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
46 | (if (formp ast) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
47 | ;; ast is valid, modify object, set ast nil |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
48 | (progn |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
49 | (sb-int:doplist (k v) ast |
342 | 50 | (when-let ((s (find-homer-symbol k))) ;; needs to be correct package |
51 | (setf (slot-value self s) v))) |
|
206
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
52 | (setf (ast self) nil) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
53 | self) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
54 | ;; invalid ast, signal error |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
55 | (error 'sxp-syntax-error)))) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
56 | |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
57 | ;; obj -> ast |
289
c4682fedd73d
added krypt lib, will probably add homer too
Richard Westhaver <ellis@rwest.io>
parents:
206
diff
changeset
|
58 | (defmethod build-ast ((self home-config) &key (nullp nil) (exclude '(ast id))) |
206
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
59 | (setf (ast self) |
351 | 60 | (unwrap-object self |
61 | :slots t |
|
62 | :methods nil |
|
63 | :nullp nullp |
|
64 | :exclude exclude))) |
|
65 | ||
206
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
66 | (defun load-homerc (&optional (file *default-user-homerc*)) |
96 | 67 | "Load a homerc configuration from FILE. Defaults to ~/.homerc." |
344 | 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* |
|
349 | 72 | (if src |
344 | 73 | (setf src (pathname src)) |
349 | 74 | (if-let ((homer (sb-posix:getenv "HOMER"))) |
75 | (setf src (pathname homer)) |
|
76 | (error "missing HOMER directory"))))))) |
|
96 | 77 | |
342 | 78 | ;;; CLI |
561 | 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))) |
|
96 | 83 | |
84 | (defcmd homer-show |
|
342 | 85 | (describe *home-config*)) |
86 | ||
345 | 87 | (defun mtime (path) (sb-posix:stat-mtime (sb-posix:stat path))) |
355 | 88 | (defun ctime (path) (sb-posix:stat-ctime (sb-posix:stat path))) |
345 | 89 | |
352 | 90 | (defun compare-home-file (src) |
342 | 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." |
|
345 | 93 | (let* ((name (enough-namestring src)) |
94 | (home (merge-pathnames name (user-homedir-pathname))) |
|
95 | (m1 (mtime src)) |
|
96 | (m2 (when (probe-file home) (mtime home))) |
|
351 | 97 | (status (cond |
98 | ((null m2) :new) |
|
99 | ((> m1 m2) :pull) |
|
355 | 100 | ((< m1 m2) (unless (= (ctime home) m2) |
101 | :push)) |
|
351 | 102 | (t)))) |
103 | (cons status (cons src home)))) |
|
104 | ||
105 | (defun homer-status (file) |
|
352 | 106 | (let ((form (compare-home-file file))) |
351 | 107 | (case (car form) |
108 | ;; confirm with user |
|
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)))) |
|
112 | (t nil)))) |
|
342 | 113 | |
114 | (defcmd homer-check |
|
351 | 115 | (with-slots (src) *home-config* |
116 | (if-let ((src (probe-file src))) |
|
117 | (let ((*default-pathname-defaults* src)) |
|
118 | (mapcar #'homer-status |
|
119 | (find-files |
|
120 | *default-pathname-defaults* |
|
352 | 121 | *home-hidden-paths*))) |
351 | 122 | (error 'file-error :pathname src)))) |
123 | ||
353 | 124 | (defun homer-copy (input output) |
125 | (ensure-directories-exist output :verbose t) |
|
126 | (uiop:copy-file input output)) |
|
127 | ||
351 | 128 | (defun homer-maybe-push (file) |
352 | 129 | (let ((form (compare-home-file file))) |
351 | 130 | (case (car form) |
131 | (:push (progn |
|
132 | (println (format nil ":PUSH ~A" (cddr form))) |
|
353 | 133 | (homer-copy (cddr form) (cadr form)))) |
351 | 134 | (t nil)))) |
342 | 135 | |
351 | 136 | (defun homer-maybe-pull (file) |
352 | 137 | (let ((form (compare-home-file file))) |
351 | 138 | (case (car form) |
139 | (:pull (progn |
|
352 | 140 | (println (format nil ":PULL ~A" (cddr form))) |
353 | 141 | (homer-copy (cadr form) (cddr form)))) |
351 | 142 | (t nil)))) |
143 | ||
352 | 144 | (defun homer-maybe-install (file) |
145 | (let ((form (compare-home-file file))) |
|
146 | (case (car form) |
|
147 | (:pull (progn |
|
148 | (println (format nil ":PULL ~A" (cddr form))) |
|
353 | 149 | (homer-copy (cadr form) (cddr form)))) |
352 | 150 | (:new (progn |
151 | (println (format nil ":NEW ~A" (cddr form))) |
|
353 | 152 | (homer-copy (cadr form) (cddr form)))) |
355 | 153 | (:push (if *homer-force* |
154 | (progn |
|
155 | (println (format nil ":OVERWRITE ~A" (cddr form))) |
|
156 | (homer-copy (cadr form) (cddr form))) |
|
157 | (trace! "skipping file:" (cddr form)))) |
|
352 | 158 | (t nil)))) |
159 | ||
351 | 160 | (defcmd homer-push |
161 | (with-slots (src) *home-config* |
|
162 | (if-let ((src (probe-file src))) |
|
163 | (let ((*default-pathname-defaults* src)) |
|
164 | (mapc #'homer-maybe-push |
|
352 | 165 | (find-files src *home-hidden-paths*))) |
351 | 166 | (error 'file-error :pathname src)))) |
167 | ||
168 | (defcmd homer-pull |
|
169 | (with-slots (src) *home-config* |
|
170 | (if-let ((src (probe-file src))) |
|
171 | (let ((*default-pathname-defaults* src)) |
|
172 | (mapc #'homer-maybe-pull |
|
352 | 173 | (find-files src *home-hidden-paths*))) |
351 | 174 | (error 'file-error :pathname src)))) |
175 | ||
352 | 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)))) |
|
183 | ||
561 | 184 | (define-cli *cli* |
96 | 185 | :name "homer" |
186 | :version "0.1.0" |
|
289
c4682fedd73d
added krypt lib, will probably add homer too
Richard Westhaver <ellis@rwest.io>
parents:
206
diff
changeset
|
187 | :description "user home manager" |
584
35bb0d5ec95e
bug fixes, added freedesktop.org.xml rule. more work on prolog/dql - considering lib/lang+forrth..
Richard Westhaver <ellis@rwest.io>
parents:
569
diff
changeset
|
188 | :thunk 'homer-check |
567 | 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) |
|
352 | 194 | (:name check :thunk homer-check) |
195 | (:name push :thunk homer-push) |
|
196 | (:name pull :thunk homer-pull) |
|
197 | (:name install :thunk homer-install))) |
|
96 | 198 | |
199 | (defun run () |
|
289
c4682fedd73d
added krypt lib, will probably add homer too
Richard Westhaver <ellis@rwest.io>
parents:
206
diff
changeset
|
200 | (let ((*log-level* :info)) |
561 | 201 | (with-cli (opts cmds args) *cli* |
556 | 202 | (init-homer-vars) |
342 | 203 | (load-homerc) |
561 | 204 | (do-cmd *cli*) |
205 | (debug-opts *cli*)))) |
|
96 | 206 | |
207 | (defmain () |
|
206
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
208 | (let ((*print-readably* t)) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
209 | (run) |
a0f64fed8f2a
refactor nu ci, skel and homer updates
Richard Westhaver <ellis@rwest.io>
parents:
96
diff
changeset
|
210 | (sb-ext:exit :code 0))) |