diff options
| -rw-r--r-- | doc/properties.rst | 5 | ||||
| -rw-r--r-- | src/package.lisp | 4 | ||||
| -rw-r--r-- | src/property/apt.lisp | 52 | ||||
| -rw-r--r-- | src/property/os.lisp | 15 |
4 files changed, 72 insertions, 4 deletions
diff --git a/doc/properties.rst b/doc/properties.rst index b21f51b..3273da6 100644 --- a/doc/properties.rst +++ b/doc/properties.rst @@ -7,8 +7,9 @@ Names The names of properties may not end in the character ``.``, because that has a special meaning in unevaluated property application specifications. -Properties occupy the function cells of symbols, so do not try to define an -ordinary function with the same name as a property. +Properties with ``:APPLY`` subroutines occupy the function cells of symbols, +so except in the case of properties with no ``:APPLY`` subroutine, do not try +to define an ordinary function with the same name as a property. Working directories ------------------- diff --git a/src/package.lisp b/src/package.lisp index a0ca1b9..7fac481 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -322,6 +322,7 @@ #:debian-stable #:debian-testing #:debian-unstable + #:debian-experimental #:debian-suite #:debian-architecture #:typecase @@ -386,7 +387,8 @@ #:cache-cleaned #:trusts-key #:all-installed-p - #:none-installed-p)) + #:none-installed-p + #:suites-available-pinned)) (defpackage :consfigurator.connection.sbcl (:use #:cl #:alexandria #:consfigurator) diff --git a/src/property/apt.lisp b/src/property/apt.lisp index 312c316..1dc6997 100644 --- a/src/property/apt.lisp +++ b/src/property/apt.lisp @@ -1,6 +1,6 @@ ;;; Consfigurator -- Lisp declarative configuration management system -;;; Copyright (C) 2021 Sean Whitton <spwhitton@spwhitton.name> +;;; Copyright (C) 2017, 2021 Sean Whitton <spwhitton@spwhitton.name> ;;; This file is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -241,6 +241,56 @@ after BASENAME. CONTENT is as the content argument to FILE:HAS-CONTENT." :unapply (file:does-not-exist file))) +;;;; Pinning + +(defmethod suite-pin ((os os:debian-stable)) + (strcat "n=" (os:debian-suite os))) + +(defmethod suite-pin ((os os:debian)) + (strcat "a=" (os:debian-suite os))) + +(defmethod suite-pin-block ((pref string) (os os:debian) pin-priority) + `("Explanation: This file added by Consfigurator" + ,(strcat "Package: " pref) + ,(strcat "Pin: release " (suite-pin os)) + ,(format nil "Pin-Priority: ~D" pin-priority))) + +(defpropspec suites-available-pinned :posix (&rest pairs) + "Where PAIRS is a list of even length of alternating instances of OS:DEBIAN +and apt pin priorities, add an apt source for the instance of OS:DEBIAN and +pin that suite to a given pin value (see apt_preferences(5)). Unapply to drop +the source and unpin the suite. + +If the OS:DEBIAN is the host's OS, the suite is pinned, but no source is +added. That apt source should already be available, or you can use a property +like APT:STANDARD-SOURCES.LIST." + (:desc (loop for (os pin) on pairs by #'cddr + for suite = (os:debian-suite os) + collect #?{Debian "${suite}" pinned, priority ${pin}} + into accum + finally (return (format nil "~{~A~^; ~}" accum)))) + (:hostattrs (os:required 'os:debian)) + `(eseqprops + ,@(loop for (os pin) on pairs by #'cddr + for suite = (os:debian-suite os) + do (check-type pin integer) + collect `(file:exists-with-content + ,#?"/etc/apt/preferences.d/20${suite}.pref" + ,(suite-pin-block "*" os pin)) + unless (and + (subtypep (type-of (get-hostattrs-car :os)) 'os:debian) + (string= suite (os:debian-suite (get-hostattrs-car :os)))) + ;; Unless we are pinning a backports suite, filter out any + ;; backports sources that were added by STANDARD-SOURCES-FOR. + ;; Probably don't want those to be pinned to the same value. + collect `(additional-sources + ,suite ,(if (string-suffix-p suite "-backports") + (standard-sources-for os) + (loop for line in (standard-sources-for os) + unless (search "-backports" line) + collect line)))))) + + ;;;; Reports on installation status (defun apt-cache-policy (packages) diff --git a/src/property/os.lisp b/src/property/os.lisp index cec032d..553e60d 100644 --- a/src/property/os.lisp +++ b/src/property/os.lisp @@ -39,6 +39,9 @@ (defclass debian-stable (debian) ()) +(defun debian-stable (suite) + (make-instance 'debian-stable :suite suite)) + (defprop debian-stable :posix (suite architecture) (:desc (declare (ignore architecture)) @@ -51,6 +54,9 @@ (defclass debian-testing (debian) ((suite :initform "testing"))) +(defun debian-testing () + (make-instance 'debian-testing)) + (defprop debian-testing :posix (architecture) (:desc (declare (ignore architecture)) @@ -63,6 +69,9 @@ (defclass debian-unstable (debian) ((suite :initform "unstable"))) +(defun debian-unstable () + (make-instance 'debian-unstable)) + (defprop debian-unstable :posix (architecture) (:desc (declare (ignore architecture)) @@ -72,6 +81,12 @@ (make-instance 'debian-unstable :arch architecture)))) +(defclass debian-experimental (debian) + ((suite :initform "experimental"))) + +(defun debian-experimental () + (make-instance 'debian-experimental)) + (defmethod debian-architecture ((os linux)) "Return a string representing the architecture of OS as used by Debian." (string-downcase (symbol-name (linux-architecture os)))) |