projects/guix·blob python-team · refs

226 lines · 8.7 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2019 Guillaume Le Vaillant <[email protected]>
3;;; Copyright © 2023 Brian Cully <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20(define-module (gnu services pam-mount)
21 #:use-module (gnu packages admin)
22 #:use-module (gnu services)
23 #:use-module (gnu services configuration)
24 #:use-module (gnu system pam)
25 #:use-module (guix gexp)
26 #:use-module (guix records)
27 #:use-module (ice-9 match)
28 #:use-module (srfi srfi-1)
29 #:export (pam-mount-configuration
30 pam-mount-configuration?
31 pam-mount-service-type
32
33 pam-mount-volume
34 pam-mount-volume?
35 pam-mount-volume-service-type))
36
37(define %pam-mount-default-configuration
38 `((debug (@ (enable "0")))
39 (mntoptions (@ (allow ,(string-join
40 '("nosuid" "nodev" "loop"
41 "encryption" "fsck" "nonempty"
42 "allow_root" "allow_other")
43 ","))))
44 (mntoptions (@ (require "nosuid,nodev")))
45 (logout (@ (wait "0")
46 (hup "0")
47 (term "no")
48 (kill "no")))
49 (mkmountpoint (@ (enable "1")
50 (remove "true")))))
51
52(define (make-pam-mount-configuration-file config)
53 (computed-file
54 "pam_mount.conf.xml"
55 #~(begin
56 (use-modules (sxml simple))
57 (call-with-output-file #$output
58 (lambda (port)
59 (sxml->xml
60 '(*TOP*
61 (*PI* xml "version='1.0' encoding='utf-8'")
62 (pam_mount
63 #$@(pam-mount-configuration-rules config)
64 (pmvarrun
65 #$(file-append pam-mount
66 "/sbin/pmvarrun -u '%(USER)' -o '%(OPERATION)'"))
67 (cryptmount
68 #$(file-append pam-mount
69 (string-append
70 "/sbin/mount.crypt"
71 " '%(if %(CIPHER),-ocipher=%(CIPHER))'"
72 " '%(if %(FSKEYCIPHER),"
73 "-ofsk_cipher=%(FSKEYCIPHER))'"
74 " '%(if %(FSKEYHASH),-ofsk_hash=%(FSKEYHASH))'"
75 " '%(if %(FSKEYPATH),-okeyfile=%(FSKEYPATH))'"
76 " '%(if %(OPTIONS),-o%(OPTIONS))'"
77 " '%(VOLUME)' '%(MNTPT)'")))
78 (cryptumount
79 #$(file-append pam-mount "/sbin/umount.crypt '%(MNTPT)'"))))
80 port))))))
81
82(define-record-type* <pam-mount-configuration>
83 pam-mount-configuration
84 make-pam-mount-configuration
85 pam-mount-configuration?
86 (rules pam-mount-configuration-rules
87 (default %pam-mount-default-configuration)))
88
89(define (pam-mount-etc-service config)
90 `(("security/pam_mount.conf.xml"
91 ,(make-pam-mount-configuration-file config))))
92
93(define (pam-mount-pam-service config)
94 (define optional-pam-mount
95 (pam-entry
96 (control "optional")
97 (module (file-append pam-mount "/lib/security/pam_mount.so"))))
98 (list
99 (pam-extension
100 (transformer
101 (lambda (pam)
102 (if (member (pam-service-name pam)
103 '("login" "greetd" "su" "slim" "gdm-password" "sddm"))
104 (pam-service
105 (inherit pam)
106 (auth (append (pam-service-auth pam)
107 (list optional-pam-mount)))
108 (session (append (pam-service-session pam)
109 (list optional-pam-mount))))
110 pam))))))
111
112(define (extend-pam-mount-configuration initial extensions)
113 "Extends INITIAL with EXTENSIONS."
114 (pam-mount-configuration (rules (append (pam-mount-configuration-rules
115 initial) extensions))))
116
117(define pam-mount-service-type
118 (service-type
119 (name 'pam-mount)
120 (extensions (list (service-extension etc-service-type
121 pam-mount-etc-service)
122 (service-extension pam-root-service-type
123 pam-mount-pam-service)))
124 (compose concatenate)
125 (extend extend-pam-mount-configuration)
126 (default-value (pam-mount-configuration))
127 (description "Activate PAM-Mount support. It allows mounting volumes for
128specific users when they log in.")))
129
130(define (field-name->tag field-name)
131 "Convert FIELD-NAME to its tag used by the configuration XML."
132 (match field-name
133 ('user-name 'user)
134 ('user-id 'uid)
135 ('primary-group 'pgrp)
136 ('group-id 'gid)
137 ('secondary-group 'sgrp)
138 ('file-system-type 'fstype)
139 ('no-mount-as-root? 'noroot)
140 ('file-name 'path)
141 ('mount-point 'mountpoint)
142 ('ssh? 'ssh)
143 ('file-system-key-cipher 'fskeycipher)
144 ('file-system-key-hash 'fskeyhash)
145 ('file-system-key-file-name 'fskeypath)
146 (_ field-name)))
147
148(define-maybe string)
149
150(define (serialize-string field-name value)
151 (list (field-name->tag field-name) value))
152
153(define (integer-or-range? value)
154 (match value
155 ((start . end) (and (integer? start)
156 (integer? end)))
157 (_ (number? value))))
158
159(define-maybe integer-or-range)
160
161(define (serialize-integer-or-range field-name value)
162 (let ((value-string (match value
163 ((start . end) (format #f "~a-~a" start end))
164 (_ (number->string value)))))
165 (list (field-name->tag field-name) value-string)))
166
167(define-maybe boolean)
168
169(define (serialize-boolean field-name value)
170 (let ((value-string (if value "1" "0")))
171 (list (field-name->tag field-name) value-string)))
172
173(define-configuration pam-mount-volume
174 (user-name maybe-string "User name to match.")
175 (user-id maybe-integer-or-range
176 "User ID, or range of user IDs, in the form of @code{(start . end)} to\nmatch.")
177 (primary-group maybe-string "Primary group name to match.")
178 (group-id maybe-integer-or-range
179 "Group ID, or range of group IDs, in the form of @code{(start . end)} to\nmatch.")
180 (secondary-group maybe-string
181 "Match users who belong to this group name as either a primary or secondary\ngroup.")
182 (file-system-type maybe-string "File system type of volume being mounted.")
183 (no-mount-as-root? maybe-boolean
184 "Do not use super user privileges to mount this volume.")
185 (server maybe-string "Remote server this volume resides on.")
186 (file-name maybe-string "Location of the volume to be mounted.")
187 (mount-point maybe-string
188 "Where to mount the volume in the local file system.")
189 (options maybe-string "Options to pass to the underlying mount program.")
190 (ssh? maybe-boolean "Whether to pass the login password to SSH.")
191 (cipher maybe-string "Cryptsetup cipher named used by volume.")
192 (file-system-key-cipher maybe-string
193 "Cipher name used by the target volume.")
194 (file-system-key-hash maybe-string
195 "SSL hash name used by the target volume.")
196 (file-system-key-file-name maybe-string
197 "File name for the file system key used by the target volume."))
198
199(define (pam-mount-volume->sxml volume)
200 ;; Convert a list of configuration fields into an SXML-compatible attribute
201 ;; list.
202 (define xml-attrs
203 (filter-map (lambda (field)
204 (let* ((accessor (configuration-field-getter field))
205 (value (accessor volume)))
206 (and (not (eq? value %unset-value))
207 (list (field-name->tag (configuration-field-name
208 field)) value))))
209 pam-mount-volume-fields))
210
211 `(volume (@ ,@xml-attrs)))
212
213(define (pam-mount-volume-rules volumes)
214 (map pam-mount-volume->sxml volumes))
215
216(define pam-mount-volume-service-type
217 (service-type (name 'pam-mount-volume)
218 (extensions (list (service-extension pam-mount-service-type
219 pam-mount-volume-rules)))
220 (compose concatenate)
221 (extend append)
222 (default-value '())
223 (description
224 "Mount remote volumes such as CIFS shares @i{via}
225@acronym{PAM, Pluggable Authentication Modules} when logging in, using login
226credentials.")))