Add package profile install commands
This commit is contained in:
@@ -0,0 +1,18 @@
|
||||
;; Example Fruix development system declaration.
|
||||
;;
|
||||
;; You can use this as a starting point for /etc/fruix/system.scm and then run:
|
||||
;; fruix system build /etc/fruix/system.scm --system dev-tools-operating-system
|
||||
;; or on an installed Fruix node:
|
||||
;; fruix system reconfigure /etc/fruix/system.scm --system dev-tools-operating-system
|
||||
|
||||
(use-modules (fruix system freebsd)
|
||||
(fruix packages freebsd))
|
||||
|
||||
(define dev-tools-operating-system
|
||||
(operating-system
|
||||
#:host-name "fruix-dev"
|
||||
;; The recovered development profile now includes:
|
||||
;; freebsd-nodejs, freebsd-npm, freebsd-ripgrep, freebsd-tmux, freebsd-neovim
|
||||
;; along with the existing compiler/build tools.
|
||||
#:development-packages %freebsd-development-profile-packages
|
||||
#:build-packages %freebsd-development-profile-packages))
|
||||
@@ -597,6 +597,9 @@
|
||||
" fruix package search QUERY\n"
|
||||
" fruix package show NAME\n"
|
||||
" fruix package build NAME [--store DIR]\n"
|
||||
" fruix package installed [--profile DIR]\n"
|
||||
" fruix package install NAME... [--profile DIR] [--store DIR]\n"
|
||||
" fruix package remove NAME... [--profile DIR] [--store DIR]\n"
|
||||
"EOF\n"
|
||||
"}\n\n"
|
||||
"die()\n"
|
||||
|
||||
+223
-8
@@ -7,6 +7,7 @@
|
||||
(fruix system storage)
|
||||
(fruix system freebsd utils)
|
||||
(fruix packages freebsd)
|
||||
(guix build utils)
|
||||
(ice-9 format)
|
||||
(ice-9 match)
|
||||
(ice-9 hash-table)
|
||||
@@ -55,9 +56,13 @@ Package actions:\n\
|
||||
search QUERY Search known Fruix packages by name or text.\n\
|
||||
show NAME Show metadata for one Fruix package.\n\
|
||||
build NAME Materialize one Fruix package in /frx/store.\n\
|
||||
installed List packages installed in a Fruix package profile.\n\
|
||||
install NAME... Add packages to a Fruix package profile.\n\
|
||||
remove NAME... Remove packages from a Fruix package profile.\n\
|
||||
\n\
|
||||
Package options:\n\
|
||||
--store DIR Store directory to use for 'build' (default: /frx/store).\n\
|
||||
--store DIR Store directory to use for 'build' or profile updates (default: /frx/store).\n\
|
||||
--profile DIR Package profile state directory (default: $HOME/.local/state/fruix/profiles/default).\n\
|
||||
\n\
|
||||
Source actions:\n\
|
||||
materialize Materialize a declared FreeBSD source tree in /frx/store.\n\
|
||||
@@ -289,24 +294,30 @@ Common options:\n\
|
||||
(define (parse-package-arguments action rest)
|
||||
(let loop ((args rest)
|
||||
(positional '())
|
||||
(store-dir "/frx/store"))
|
||||
(store-dir "/frx/store")
|
||||
(profile-dir #f))
|
||||
(match args
|
||||
(()
|
||||
(let ((positional (reverse positional)))
|
||||
`((command . "package")
|
||||
(action . ,action)
|
||||
(positional . ,positional)
|
||||
(store-dir . ,store-dir))))
|
||||
(store-dir . ,store-dir)
|
||||
(profile-dir . ,profile-dir))))
|
||||
(("--help")
|
||||
(usage 0))
|
||||
(((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
|
||||
(loop tail positional (option-value arg "--store=")))
|
||||
(loop tail positional (option-value arg "--store=") profile-dir))
|
||||
(("--store" value . tail)
|
||||
(loop tail positional value))
|
||||
(loop tail positional value profile-dir))
|
||||
(((? (lambda (arg) (string-prefix? "--profile=" arg)) arg) . tail)
|
||||
(loop tail positional store-dir (option-value arg "--profile=")))
|
||||
(("--profile" value . tail)
|
||||
(loop tail positional store-dir value))
|
||||
(((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
|
||||
(error "unknown option" arg))
|
||||
((arg . tail)
|
||||
(loop tail (cons arg positional) store-dir)))))
|
||||
(loop tail (cons arg positional) store-dir profile-dir)))))
|
||||
|
||||
(define (parse-native-build-arguments action rest)
|
||||
(let loop ((args rest)
|
||||
@@ -754,6 +765,179 @@ Common options:\n\
|
||||
(references_file . ,(string-append store-path "/.references"))
|
||||
(package_metadata_file . ,(string-append store-path "/.fruix-package")))))
|
||||
|
||||
(define profile-manifest-version "1")
|
||||
|
||||
(define (default-package-profile-dir)
|
||||
(let ((home (or (getenv "HOME") ".")))
|
||||
(string-append home "/.local/state/fruix/profiles/default")))
|
||||
|
||||
(define (package-profile-manifest-path profile-dir)
|
||||
(string-append profile-dir "/manifest.scm"))
|
||||
|
||||
(define (package-profile-generation-file profile-dir)
|
||||
(string-append profile-dir "/current-generation"))
|
||||
|
||||
(define (package-profile-current-link profile-dir)
|
||||
(string-append profile-dir "/current"))
|
||||
|
||||
(define (package-profile-generate-link profile-dir generation)
|
||||
(string-append profile-dir "/generations/" (number->string generation)))
|
||||
|
||||
(define (path-directory path)
|
||||
(let ((index (string-index-right path #\/)))
|
||||
(if index
|
||||
(substring path 0 index)
|
||||
".")))
|
||||
|
||||
(define (path-present? path)
|
||||
(or (file-exists? path)
|
||||
(false-if-exception (readlink path))))
|
||||
|
||||
(define (symlink-force target link-name)
|
||||
(mkdir-p (path-directory link-name))
|
||||
(delete-path-if-exists link-name)
|
||||
(symlink target link-name))
|
||||
|
||||
(define (merge-node source destination)
|
||||
(let ((kind (stat:type (lstat source))))
|
||||
(case kind
|
||||
((directory)
|
||||
(mkdir-p destination)
|
||||
(for-each (lambda (entry)
|
||||
(merge-node (string-append source "/" entry)
|
||||
(string-append destination "/" entry)))
|
||||
(directory-entries source)))
|
||||
((symlink)
|
||||
(unless (path-present? destination)
|
||||
(mkdir-p (path-directory destination))
|
||||
(symlink (readlink source) destination)))
|
||||
(else
|
||||
(unless (file-exists? destination)
|
||||
(copy-node source destination))))))
|
||||
|
||||
(define (merge-package-output source-root target-root)
|
||||
(mkdir-p target-root)
|
||||
(for-each (lambda (entry)
|
||||
(unless (string-prefix? "." entry)
|
||||
(merge-node (string-append source-root "/" entry)
|
||||
(string-append target-root "/" entry))))
|
||||
(directory-entries source-root)))
|
||||
|
||||
(define (package-profile-activate-script)
|
||||
(string-append
|
||||
"#!/bin/sh\n"
|
||||
"set -eu\n"
|
||||
"profile=$(CDPATH= cd -- \"$(dirname \"$0\")\" && pwd)\n"
|
||||
"cat <<EOF\n"
|
||||
"export FRUIX_PROFILE=\"$profile\"\n"
|
||||
"export PATH=\"$profile/bin:$profile/sbin:$profile/usr/bin:$profile/usr/sbin${PATH:+:$PATH}\"\n"
|
||||
"export LD_LIBRARY_PATH=\"$profile/lib:$profile/usr/lib${LD_LIBRARY_PATH:+:$LD_LIBRARY_PATH}\"\n"
|
||||
"export MANPATH=\"$profile/share/man:$profile/usr/share/man${MANPATH:+:$MANPATH}\"\n"
|
||||
"export NODE_PATH=\"$profile/lib/node_modules${NODE_PATH:+:$NODE_PATH}\"\n"
|
||||
"export VIMRUNTIME=\"$profile/share/nvim/runtime\"\n"
|
||||
"export LUA_CPATH=\"$profile/lib/lua/5.1/?.so${LUA_CPATH:+;$LUA_CPATH};;\"\n"
|
||||
"EOF\n"))
|
||||
|
||||
(define (read-package-profile-manifest profile-dir)
|
||||
(let ((path (package-profile-manifest-path profile-dir)))
|
||||
(if (file-exists? path)
|
||||
(call-with-input-file path read)
|
||||
'((version . "1")
|
||||
(packages . ())))))
|
||||
|
||||
(define (package-profile-package-names profile-dir)
|
||||
(let ((manifest (read-package-profile-manifest profile-dir)))
|
||||
(or (assoc-ref manifest 'packages) '())))
|
||||
|
||||
(define (normalize-package-names names)
|
||||
(sort (delete-duplicates names string=?) string<?))
|
||||
|
||||
(define (resolve-package-list names)
|
||||
(map (lambda (name)
|
||||
(or (find-freebsd-package name)
|
||||
(error "unknown package" name)))
|
||||
names))
|
||||
|
||||
(define (materialize-package-profile package-names store-dir)
|
||||
(let* ((normalized (normalize-package-names package-names))
|
||||
(packages (resolve-package-list normalized))
|
||||
(cache (make-hash-table))
|
||||
(source-cache (make-hash-table))
|
||||
(package-stores (map (lambda (package)
|
||||
(materialize-freebsd-package package store-dir cache source-cache))
|
||||
packages))
|
||||
(payload (object->string `((profile-version . ,profile-manifest-version)
|
||||
(packages . ,normalized)
|
||||
(package-stores . ,package-stores))))
|
||||
(profile-store (make-store-path store-dir "fruix-package-profile" payload
|
||||
#:kind 'profile)))
|
||||
(unless (file-exists? profile-store)
|
||||
(mkdir-p profile-store)
|
||||
(for-each (lambda (store)
|
||||
(merge-package-output store profile-store))
|
||||
package-stores)
|
||||
(write-file (string-append profile-store "/.references")
|
||||
(string-join package-stores "\n"))
|
||||
(write-file (string-append profile-store "/.fruix-profile.scm")
|
||||
(object->string `((version . ,profile-manifest-version)
|
||||
(packages . ,normalized)
|
||||
(package-stores . ,package-stores))))
|
||||
(write-file (string-append profile-store "/activate")
|
||||
(package-profile-activate-script))
|
||||
(chmod (string-append profile-store "/activate") #o555))
|
||||
`((profile-store . ,profile-store)
|
||||
(package-stores . ,package-stores)
|
||||
(packages . ,normalized))))
|
||||
|
||||
(define (next-package-profile-generation profile-dir)
|
||||
(let ((path (package-profile-generation-file profile-dir)))
|
||||
(if (file-exists? path)
|
||||
(+ 1 (string->number (call-with-input-file path get-string-all)))
|
||||
1)))
|
||||
|
||||
(define (update-package-profile profile-dir store-dir package-names)
|
||||
(let* ((materialized (materialize-package-profile package-names store-dir))
|
||||
(normalized (assoc-ref materialized 'packages))
|
||||
(profile-store (assoc-ref materialized 'profile-store))
|
||||
(generation (next-package-profile-generation profile-dir))
|
||||
(generation-link (package-profile-generate-link profile-dir generation))
|
||||
(current-link (package-profile-current-link profile-dir))
|
||||
(activate-link (string-append profile-dir "/activate"))
|
||||
(manifest-path (package-profile-manifest-path profile-dir)))
|
||||
(mkdir-p (string-append profile-dir "/generations"))
|
||||
(symlink-force profile-store generation-link)
|
||||
(symlink-force (string-append "generations/" (number->string generation))
|
||||
current-link)
|
||||
(symlink-force "current/activate" activate-link)
|
||||
(write-file (package-profile-generation-file profile-dir)
|
||||
(number->string generation))
|
||||
(write-file manifest-path
|
||||
(object->string `((version . ,profile-manifest-version)
|
||||
(generation . ,generation)
|
||||
(profile-store . ,profile-store)
|
||||
(packages . ,normalized))))
|
||||
`((profile-dir . ,profile-dir)
|
||||
(generation . ,generation)
|
||||
(profile-store . ,profile-store)
|
||||
(current-link . ,current-link)
|
||||
(activate-link . ,activate-link)
|
||||
(manifest-path . ,manifest-path)
|
||||
(packages . ,normalized)
|
||||
(package-count . ,(length normalized)))))
|
||||
|
||||
(define (emit-package-profile-metadata action store-dir result)
|
||||
(emit-metadata
|
||||
`((action . ,action)
|
||||
(store_dir . ,store-dir)
|
||||
(profile_dir . ,(assoc-ref result 'profile-dir))
|
||||
(generation . ,(assoc-ref result 'generation))
|
||||
(profile_store . ,(assoc-ref result 'profile-store))
|
||||
(current_link . ,(assoc-ref result 'current-link))
|
||||
(activate_link . ,(assoc-ref result 'activate-link))
|
||||
(manifest_path . ,(assoc-ref result 'manifest-path))
|
||||
(package_count . ,(assoc-ref result 'package-count))
|
||||
(packages . ,(string-join (assoc-ref result 'packages) ",")))))
|
||||
|
||||
(define (shell-quote text)
|
||||
(string-append "'" (string-replace-all text "'" "'\"'\"'") "'"))
|
||||
|
||||
@@ -1154,10 +1338,12 @@ Common options:\n\
|
||||
#:disk-capacity disk-capacity))))))))))))
|
||||
((string=? command "package")
|
||||
(let* ((positional (assoc-ref parsed 'positional))
|
||||
(profile-dir (or (assoc-ref parsed 'profile-dir)
|
||||
(default-package-profile-dir)))
|
||||
(name-or-query (match positional
|
||||
((value . _) value)
|
||||
(() #f))))
|
||||
(unless (member action '("list" "search" "show" "build"))
|
||||
(unless (member action '("list" "search" "show" "build" "installed" "install" "remove"))
|
||||
(error "unknown package action" action))
|
||||
(cond
|
||||
((string=? action "list")
|
||||
@@ -1188,7 +1374,36 @@ Common options:\n\
|
||||
(materialize-freebsd-package package
|
||||
store-dir
|
||||
(make-hash-table)
|
||||
(make-hash-table))))))))
|
||||
(make-hash-table)))))
|
||||
((string=? action "installed")
|
||||
(for-each (lambda (name)
|
||||
(let ((package (find-freebsd-package name)))
|
||||
(if package
|
||||
(format #t "~a~%" (package-summary-line package))
|
||||
(format #t "~a\tunknown\tunknown\tUnknown package recorded in profile\n" name))))
|
||||
(package-profile-package-names profile-dir)))
|
||||
((string=? action "install")
|
||||
(unless (pair? positional)
|
||||
(error "package install requires at least one package name"))
|
||||
(emit-package-profile-metadata
|
||||
"package-install"
|
||||
store-dir
|
||||
(update-package-profile profile-dir
|
||||
store-dir
|
||||
(append (package-profile-package-names profile-dir)
|
||||
positional))))
|
||||
((string=? action "remove")
|
||||
(unless (pair? positional)
|
||||
(error "package remove requires at least one package name"))
|
||||
(let ((removals (normalize-package-names positional)))
|
||||
(emit-package-profile-metadata
|
||||
"package-remove"
|
||||
store-dir
|
||||
(update-package-profile profile-dir
|
||||
store-dir
|
||||
(filter (lambda (name)
|
||||
(not (member name removals)))
|
||||
(package-profile-package-names profile-dir)))))))))
|
||||
((string=? command "source")
|
||||
(let* ((positional (assoc-ref parsed 'positional))
|
||||
(cache-dir (assoc-ref parsed 'cache-dir))
|
||||
|
||||
@@ -0,0 +1,147 @@
|
||||
(use-modules (ice-9 match)
|
||||
(srfi srfi-1)
|
||||
(srfi srfi-13)
|
||||
(srfi srfi-64)
|
||||
(fruix system freebsd utils))
|
||||
|
||||
(define repo-root
|
||||
(or (getenv "FRUIX_REPO_ROOT")
|
||||
(error "FRUIX_REPO_ROOT is not set")))
|
||||
|
||||
(define guile-bin
|
||||
(or (getenv "GUILE_BIN")
|
||||
(error "GUILE_BIN is not set")))
|
||||
|
||||
(define fruix-script
|
||||
(string-append repo-root "/scripts/fruix.scm"))
|
||||
|
||||
(define (cli-output . args)
|
||||
(apply command-output guile-bin
|
||||
(append '("--no-auto-compile" "-s")
|
||||
(list fruix-script)
|
||||
args)))
|
||||
|
||||
(define (output-lines text)
|
||||
(filter (lambda (line) (not (string-null? line)))
|
||||
(string-split text #\newline)))
|
||||
|
||||
(define (summary-line-name line)
|
||||
(car (string-split line #\tab)))
|
||||
|
||||
(define (metadata-value text key)
|
||||
(let ((prefix (string-append key "=")))
|
||||
(let loop ((lines (output-lines text)))
|
||||
(match lines
|
||||
(() #f)
|
||||
((line . rest)
|
||||
(if (string-prefix? prefix line)
|
||||
(substring line (string-length prefix))
|
||||
(loop rest)))))))
|
||||
|
||||
(define (path-present? path)
|
||||
(or (file-exists? path)
|
||||
(false-if-exception (readlink path))))
|
||||
|
||||
(test-begin "package-profile")
|
||||
|
||||
(let* ((store-dir (mktemp-directory "/tmp/fruix-package-profile-store.XXXXXX"))
|
||||
(profile-dir (mktemp-directory "/tmp/fruix-package-profile-state.XXXXXX"))
|
||||
(install-output
|
||||
(cli-output "package" "install"
|
||||
"freebsd-nodejs" "freebsd-npm"
|
||||
"--store" store-dir
|
||||
"--profile" profile-dir))
|
||||
(installed-output-1
|
||||
(cli-output "package" "installed"
|
||||
"--profile" profile-dir))
|
||||
(install-output-2
|
||||
(cli-output "package" "install"
|
||||
"freebsd-ripgrep" "freebsd-tmux"
|
||||
"--store" store-dir
|
||||
"--profile" profile-dir))
|
||||
(remove-output
|
||||
(cli-output "package" "remove"
|
||||
"freebsd-npm" "freebsd-tmux"
|
||||
"--store" store-dir
|
||||
"--profile" profile-dir))
|
||||
(installed-output-2
|
||||
(cli-output "package" "installed"
|
||||
"--profile" profile-dir))
|
||||
(current-link (string-append profile-dir "/current"))
|
||||
(activate-link (string-append profile-dir "/activate"))
|
||||
(manifest-path (string-append profile-dir "/manifest.scm"))
|
||||
(first-profile-store (metadata-value install-output "profile_store"))
|
||||
(second-profile-store (metadata-value install-output-2 "profile_store"))
|
||||
(third-profile-store (metadata-value remove-output "profile_store")))
|
||||
(test-equal "package install reports action"
|
||||
"package-install"
|
||||
(metadata-value install-output "action"))
|
||||
(test-equal "first profile generation is 1"
|
||||
"1"
|
||||
(metadata-value install-output "generation"))
|
||||
(test-assert "profile current link exists"
|
||||
(false-if-exception (readlink current-link)))
|
||||
(test-assert "profile activate link exists"
|
||||
(false-if-exception (readlink activate-link)))
|
||||
(test-assert "profile manifest exists"
|
||||
(file-exists? manifest-path))
|
||||
(test-assert "node is present in the first profile store"
|
||||
(path-present? (string-append first-profile-store "/bin/node")))
|
||||
(test-assert "npm is present in the first profile store"
|
||||
(path-present? (string-append first-profile-store "/bin/npm")))
|
||||
(test-assert "activate script exists in the first profile store"
|
||||
(path-present? (string-append first-profile-store "/activate")))
|
||||
(test-assert "installed lists nodejs after first install"
|
||||
(member "freebsd-nodejs"
|
||||
(map summary-line-name (output-lines installed-output-1))))
|
||||
(test-assert "installed lists npm after first install"
|
||||
(member "freebsd-npm"
|
||||
(map summary-line-name (output-lines installed-output-1))))
|
||||
(test-equal "activate script exposes node"
|
||||
"v24.14.0"
|
||||
(command-output "sh" "-eu" "-c"
|
||||
"eval \"$($0)\"; node --version"
|
||||
activate-link))
|
||||
|
||||
(test-equal "second profile generation is 2"
|
||||
"2"
|
||||
(metadata-value install-output-2 "generation"))
|
||||
(test-assert "ripgrep is present after second install"
|
||||
(path-present? (string-append second-profile-store "/bin/rg")))
|
||||
(test-assert "tmux is present after second install"
|
||||
(path-present? (string-append second-profile-store "/bin/tmux")))
|
||||
(test-equal "activate script exposes ripgrep after second install"
|
||||
"ripgrep 15.1.0"
|
||||
(car (output-lines
|
||||
(command-output "sh" "-eu" "-c"
|
||||
"eval \"$($0)\"; rg --version | head -1"
|
||||
activate-link))))
|
||||
|
||||
(test-equal "package remove reports action"
|
||||
"package-remove"
|
||||
(metadata-value remove-output "action"))
|
||||
(test-equal "third profile generation is 3"
|
||||
"3"
|
||||
(metadata-value remove-output "generation"))
|
||||
(test-assert "node remains after remove"
|
||||
(path-present? (string-append third-profile-store "/bin/node")))
|
||||
(test-assert "ripgrep remains after remove"
|
||||
(path-present? (string-append third-profile-store "/bin/rg")))
|
||||
(test-assert "npm is removed from the current profile"
|
||||
(not (path-present? (string-append third-profile-store "/bin/npm"))))
|
||||
(test-assert "tmux is removed from the current profile"
|
||||
(not (path-present? (string-append third-profile-store "/bin/tmux"))))
|
||||
(test-assert "installed still lists nodejs"
|
||||
(member "freebsd-nodejs"
|
||||
(map summary-line-name (output-lines installed-output-2))))
|
||||
(test-assert "installed still lists ripgrep"
|
||||
(member "freebsd-ripgrep"
|
||||
(map summary-line-name (output-lines installed-output-2))))
|
||||
(test-assert "installed no longer lists npm"
|
||||
(not (member "freebsd-npm"
|
||||
(map summary-line-name (output-lines installed-output-2)))))
|
||||
(test-assert "installed no longer lists tmux"
|
||||
(not (member "freebsd-tmux"
|
||||
(map summary-line-name (output-lines installed-output-2))))))
|
||||
|
||||
(test-end "package-profile")
|
||||
Executable
+17
@@ -0,0 +1,17 @@
|
||||
#!/bin/sh
|
||||
set -eu
|
||||
|
||||
repo_root=$(CDPATH= cd -- "$(dirname "$0")/.." && pwd)
|
||||
. "$HOME/.local/opt/fruix-builder/env.sh"
|
||||
|
||||
guile_version=$($GUILE_BIN -c '(display (effective-version))')
|
||||
guile_load_path="$repo_root/modules:$GUIX_SOURCE_DIR:$HOME/.local/opt/fruix-builder/shepherd/share/guile/site/$guile_version${GUILE_LOAD_PATH:+:$GUILE_LOAD_PATH}"
|
||||
guile_load_compiled_path="$HOME/.local/opt/fruix-builder/shepherd/lib/guile/$guile_version/site-ccache${GUILE_LOAD_COMPILED_PATH:+:$GUILE_LOAD_COMPILED_PATH}"
|
||||
|
||||
env \
|
||||
FRUIX_REPO_ROOT="$repo_root" \
|
||||
GUILE_BIN="$GUILE_BIN" \
|
||||
GUILE_AUTO_COMPILE=0 \
|
||||
GUILE_LOAD_PATH="$guile_load_path" \
|
||||
GUILE_LOAD_COMPILED_PATH="$guile_load_compiled_path" \
|
||||
"$GUILE_BIN" --no-auto-compile "$repo_root/tests/package-profile.scm"
|
||||
Reference in New Issue
Block a user