88 lines
3.4 KiB
Common Lisp
88 lines
3.4 KiB
Common Lisp
(uiop:define-package ambrevar/guix
|
|
(:documentation "Guix helpers.")
|
|
(:use #:common-lisp)
|
|
(:use #:trivia)
|
|
(:import-from #:serapeum #:export-always)
|
|
(:import-from #:ambrevar/shell))
|
|
(in-package ambrevar/guix)
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(trivial-package-local-nicknames:add-package-local-nickname :alex :alexandria)
|
|
(trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum))
|
|
|
|
(export-always 'share-setup-files)
|
|
(defun share-setup-files (&key (port 8081))
|
|
(unless (uiop:file-exists-p "/etc/guix/signing-key.pub")
|
|
(error "TODO: Implement `sudo guix archive --generate'"))
|
|
;; TODO: Generate unique temp file.
|
|
;; TODO: Use ambrevar/shell.
|
|
;; TODO: Overwrite existing file?
|
|
(let ((setup-file "/tmp/guix-system-setup.tar")
|
|
(channel-file "/tmp/channels.scm"))
|
|
(uiop:run-program (list "guix" "describe" "--format=channels")
|
|
:output channel-file)
|
|
(uiop:with-current-directory ((format nil "~a/guix/" (uiop:xdg-config-home)))
|
|
(uiop:run-program (list "tar" "--dereference" "-cvf" setup-file
|
|
"/etc/guix/signing-key.pub"
|
|
channel-file "system")
|
|
:output t))
|
|
;; TODO: Restart when port is occupied.
|
|
(format t (str:concat "Guix installation can fetch the setup files with~%"
|
|
" guix download http://~a:~a -o setup.tar && tar xf setup.tar~%")
|
|
($:current-ip)
|
|
port)
|
|
(uiop:run-program (list "woof" "-p" (write-to-string port)
|
|
setup-file)
|
|
:output :interactive)
|
|
(delete-file setup-file)))
|
|
|
|
(export-always 'publish)
|
|
(defun publish ()
|
|
(error "TODO: Implement `sudo guix publish'...")
|
|
;; (uiop:run-program `("guix" "publish" "--advertise"
|
|
;; ,(str:concat "--user=" (uiop:getenv "USER"))))
|
|
)
|
|
|
|
(export-always 'setup-all)
|
|
(defun setup-all ()
|
|
(share-setup-files)
|
|
(publish))
|
|
|
|
(export-always 'disk-usage-store)
|
|
(defun disk-usage-store (&key (limit 30)
|
|
dead?)
|
|
(flet ((size->human (pair)
|
|
(list (first pair)
|
|
(sera:format-human-size nil (second pair))))
|
|
(pair-item-with-disk-usage (path)
|
|
;; TODO: Replace `du' with native version? `disk-usage' only work on files.
|
|
(list path
|
|
(parse-integer
|
|
(first (first
|
|
($:tokenize
|
|
(cmd:$cmd "du" "-sb" path))))))))
|
|
(mapcar
|
|
#'size->human
|
|
(sera:take
|
|
limit
|
|
(sort (mapcar #'pair-item-with-disk-usage
|
|
(if dead?
|
|
(alex:flatten ($:tokenize (cmd:$cmd "guix" "gc" "--list-dead")))
|
|
(ambrevar/file:list-directory "/gnu/store" :sort)))
|
|
#'> :key #'second)))))
|
|
|
|
(export-always 'delete-store-items)
|
|
(declaim (ftype (function ((cons (or string pathname)))) delete-store-items))
|
|
(defun delete-store-items (items)
|
|
"Garbage-collect items."
|
|
(apply #'cmd:$cmd "guix" "gc" "--delete" items))
|
|
|
|
(export-always 'guix-run)
|
|
(defun guix-run (package &optional (executable package) &rest args) ; TODO: Rename to `run'?
|
|
"Garbage-collect items.
|
|
If EXECUTABLE is nil, PACKAGE is used instead."
|
|
(apply #'cmd:cmd
|
|
"guix" "environment" "--ad-hoc" package
|
|
"--"
|
|
(or executable package)
|
|
args))
|