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