184 lines
6.9 KiB
Scheme
184 lines
6.9 KiB
Scheme
(define-module (fox arch-overlay)
|
|
#:use-module (gnu services)
|
|
#:use-module (guix gexp)
|
|
#:use-module (guix store)
|
|
#:use-module (guix derivations)
|
|
#:use-module (guix profiles)
|
|
#:use-module (guix monads)
|
|
#:use-module (guix modules)
|
|
#:use-module (guix sets)
|
|
#:use-module (guix build utils)
|
|
#:use-module (guix scripts package)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 popen)
|
|
#:use-module (ice-9 rdelim)
|
|
#:use-module (ice-9 ftw)
|
|
#:use-module (srfi srfi-1)
|
|
#:export (arch-service-type
|
|
arch-files-service-type
|
|
arch-run-on-pacman-sync-service-type
|
|
build-arch-drv
|
|
))
|
|
|
|
|
|
(define (arch-derivation entries mextensions)
|
|
"Return as a monadic value the derivation of the 'arch'
|
|
directory containing the given entries."
|
|
(mlet %store-monad ((extensions (mapm/accumulate-builds identity
|
|
mextensions)))
|
|
(lower-object
|
|
(file-union "arch" (append entries (concatenate extensions))))))
|
|
|
|
(define arch-service-type
|
|
;; This is the ultimate service type, the root of the home service
|
|
;; DAG. The service of this type is extended by monadic name/item
|
|
;; pairs. These items end up in the "arch-environment directory" as
|
|
;; returned by 'arch-environment-derivation'.
|
|
(service-type (name 'arch)
|
|
(extensions '())
|
|
(compose identity)
|
|
(extend arch-derivation)
|
|
(default-value '())
|
|
(description
|
|
"Build the arch environment top-level directory,
|
|
which in turn refers to everything the home environment needs: its
|
|
packages, configuration files, activation script, and so on.")))
|
|
|
|
(define (files->files-directory files)
|
|
"Return a @code{files} directory that contains FILES."
|
|
(define (assert-no-duplicates files)
|
|
(let loop ((files files)
|
|
(seen (set)))
|
|
(match files
|
|
(() #t)
|
|
(((file _) rest ...)
|
|
(when (set-contains? seen file)
|
|
(raise (formatted-message (G_ "duplicate '~a' entry for files/")
|
|
file)))
|
|
(loop rest (set-insert file seen))))))
|
|
|
|
;; Detect duplicates early instead of letting them through, eventually
|
|
;; leading to a build failure of "files.drv".
|
|
(assert-no-duplicates files)
|
|
|
|
(file-union "files" files))
|
|
|
|
(define arch-files-directory "files")
|
|
|
|
(define (files-entry files)
|
|
"Return an entry for the files}
|
|
directory containing FILES."
|
|
(with-monad %store-monad
|
|
(return `((,arch-files-directory ,(files->files-directory files))))))
|
|
|
|
(define arch-files-service-type
|
|
(service-type (name 'arch-files)
|
|
(extensions
|
|
(list (service-extension arch-service-type
|
|
files-entry)))
|
|
(compose concatenate)
|
|
(extend append)
|
|
(default-value '())
|
|
(description "Files that will be put in
|
|
files, and further processed during activation.")))
|
|
|
|
(define (compute-pacman-sync-script _ gexps)
|
|
(program-file
|
|
"sync"
|
|
(with-imported-modules
|
|
(source-module-closure '((ice-9 popen)
|
|
(ice-9 rdelim)
|
|
(ice-9 textual-ports)))
|
|
#~(begin
|
|
(use-modules (ice-9 popen)
|
|
(ice-9 rdelim)
|
|
(ice-9 textual-ports))
|
|
|
|
(define (list-difference l1 l2)
|
|
(cond ((null? l1)
|
|
'())
|
|
((not (member (car l1) l2))
|
|
(cons (car l1) (list-difference (cdr l1) l2)))
|
|
(else
|
|
(list-difference (cdr l1) l2))))
|
|
|
|
(define arch-user-packages (string-split (call-with-input-file
|
|
(string-append (getenv "GUIX_ARCH_DRV") "/files/.arch-packages")
|
|
get-string-all) #\newline))
|
|
(define (arch-package-update)
|
|
(let ((port (open-output-pipe "pacman -Syu --noconfirm")))
|
|
(if (not (eqv? 0 (status:exit-val (close-pipe port))))
|
|
(error "Something wrong"))))
|
|
|
|
(define (arch-install-packages packages-list)
|
|
(if (not (nil? packages-list))
|
|
(let ((port (open-output-pipe (string-append "pacman -S --noconfirm "
|
|
(string-join packages-list " ")))))
|
|
(display port)
|
|
(if (not (eqv? 0 (status:exit-val (close-pipe port))))
|
|
(error "Something wrong")))
|
|
(display "Nothing to install...!")))
|
|
|
|
(define (arch-get-pacman-package-list)
|
|
(let* ((explicitly-packages (string-split (read-string (open-input-pipe "pacman -Qqe")) #\newline))
|
|
(all-packages (string-split (read-string (open-input-pipe "pacman -Qq")) #\newline)))
|
|
(display "Hint: Run \n")
|
|
(display (string-append
|
|
"pacman -R "
|
|
(string-join (list-difference explicitly-packages arch-user-packages) " ") "\n"))
|
|
(display "command to sync packages.\n")
|
|
|
|
(list-difference arch-user-packages all-packages)))
|
|
|
|
(arch-package-update)
|
|
(arch-install-packages (arch-get-pacman-package-list))
|
|
|
|
#$@gexps
|
|
))))
|
|
|
|
(define (pacman-sync-script-entry sync)
|
|
"Return, as a monadic value, an entry for the sync script
|
|
in the arch pacman overlay."
|
|
(with-monad %store-monad
|
|
(return `(("sync" ,sync)))))
|
|
|
|
(define arch-run-on-pacman-sync-service-type
|
|
(service-type (name 'arch-run-on-pacman-sync)
|
|
(extensions
|
|
(list (service-extension
|
|
arch-service-type
|
|
pacman-sync-script-entry)))
|
|
(compose identity)
|
|
(extend compute-pacman-sync-script)
|
|
(default-value #f)
|
|
(description "Run gexps on pacman sync")))
|
|
|
|
(define %arch-profile
|
|
(string-append %profile-directory "/arch-profile"))
|
|
|
|
(define %base-arch-services
|
|
(list
|
|
(service arch-service-type)
|
|
(service arch-run-on-pacman-sync-service-type)))
|
|
|
|
(define (build-arch-drv arch-services)
|
|
(let* ((arch-drv-raw
|
|
(with-store
|
|
%store
|
|
(run-with-store
|
|
%store
|
|
(service-value
|
|
(fold-services
|
|
(append %base-arch-services arch-services)
|
|
#:target-type arch-service-type)))))
|
|
(arch-drv (with-store %store (build-derivations %store (list arch-drv-raw))))
|
|
(arch-drv-output (derivation->output-path arch-drv-raw))
|
|
(number (generation-number %arch-profile))
|
|
(generation (generation-file-name
|
|
%arch-profile (+ 1 number))))
|
|
(pk generation)
|
|
(setenv "GUIX_ARCH_DRV" arch-drv-output)
|
|
(switch-symlinks generation arch-drv-output)
|
|
(switch-symlinks %arch-profile generation)
|
|
(primitive-load (string-append arch-drv-output "/sync"))
|
|
(setenv "GUIX_ARCH_DRV" #f)))
|