You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

574 lines
21 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (gnu build accounts)
  19. #:use-module (guix records)
  20. #:use-module (guix combinators)
  21. #:use-module (gnu system accounts)
  22. #:use-module (srfi srfi-1)
  23. #:use-module (srfi srfi-11)
  24. #:use-module (srfi srfi-19)
  25. #:use-module (srfi srfi-26)
  26. #:use-module (ice-9 match)
  27. #:use-module (ice-9 vlist)
  28. #:use-module (ice-9 rdelim)
  29. #:export (password-entry
  30. password-entry?
  31. password-entry-name
  32. password-entry-uid
  33. password-entry-gid
  34. password-entry-real-name
  35. password-entry-directory
  36. password-entry-shell
  37. shadow-entry
  38. shadow-entry?
  39. shadow-entry-name
  40. shadow-entry-minimum-change-period
  41. shadow-entry-maximum-change-period
  42. shadow-entry-change-warning-time
  43. shadow-entry-maximum-inactivity
  44. shadow-entry-expiration
  45. group-entry
  46. group-entry?
  47. group-entry-name
  48. group-entry-gid
  49. group-entry-members
  50. %password-lock-file
  51. write-group
  52. write-passwd
  53. write-shadow
  54. read-group
  55. read-passwd
  56. read-shadow
  57. %id-min
  58. %id-max
  59. %system-id-min
  60. %system-id-max
  61. user+group-databases))
  62. ;;; Commentary:
  63. ;;;
  64. ;;; This modules provides functionality equivalent to the C library's
  65. ;;; <shadow.h>, <pwd.h>, and <grp.h> routines, as well as a subset of the
  66. ;;; functionality of the Shadow command-line tools. It can parse and write
  67. ;;; /etc/passwd, /etc/shadow, and /etc/group. It can also take care of UID
  68. ;;; and GID allocation in a way similar to what 'useradd' does.
  69. ;;;
  70. ;;; The benefit is twofold: less code is involved, and the ID allocation
  71. ;;; strategy and state preservation is made explicit.
  72. ;;;
  73. ;;; Code:
  74. ;;;
  75. ;;; Machinery to define user and group databases.
  76. ;;;
  77. (define-syntax serialize-field
  78. (syntax-rules (serialization)
  79. ((_ entry (field get (serialization ->string string->) _ ...))
  80. (->string (get entry)))
  81. ((_ entry (field get _ ...))
  82. (get entry))))
  83. (define-syntax deserialize-field
  84. (syntax-rules (serialization)
  85. ((_ str (field get (serialization ->string string->) _ ...))
  86. (string-> str))
  87. ((_ str (field get _ ...))
  88. str)))
  89. (define-syntax let/fields
  90. (syntax-rules ()
  91. ((_ (((name get attributes ...) rest ...) lst) body ...)
  92. (let ((l lst))
  93. (let ((name (deserialize-field (car l)
  94. (name get attributes ...))))
  95. (let/fields ((rest ...) (cdr l)) body ...))))
  96. ((_ (() lst) body ...)
  97. (begin body ...))))
  98. (define-syntax define-database-entry
  99. (syntax-rules (serialization)
  100. "Define a record data type, as per 'define-record-type*', with additional
  101. information on how to serialize and deserialize the whole database as well as
  102. each field."
  103. ((_ <record> record make-record record?
  104. (serialization separator entry->string string->entry)
  105. fields ...)
  106. (let-syntax ((field-name
  107. (syntax-rules ()
  108. ((_ (name _ (... ...))) name))))
  109. (define-record-type* <record> record make-record
  110. record?
  111. fields ...)
  112. (define (entry->string entry)
  113. (string-join (list (serialize-field entry fields) ...)
  114. (string separator)))
  115. (define (string->entry str)
  116. (let/fields ((fields ...) (string-split str #\:))
  117. (make-record (field-name fields) ...)))))))
  118. (define number->string*
  119. (match-lambda
  120. ((? number? number) (number->string number))
  121. (_ "")))
  122. (define (false-if-string=? false-string)
  123. (lambda (str)
  124. (if (string=? str false-string)
  125. #f
  126. str)))
  127. (define (string-if-false str)
  128. (lambda (obj)
  129. (if (not obj) str obj)))
  130. (define (comma-separated->list str)
  131. (string-tokenize str (char-set-complement (char-set #\,))))
  132. (define (list->comma-separated lst)
  133. (string-join lst ","))
  134. ;;;
  135. ;;; Database definitions.
  136. ;;;
  137. (define-database-entry <password-entry> ;<pwd.h>
  138. password-entry make-password-entry
  139. password-entry?
  140. (serialization #\: password-entry->string string->password-entry)
  141. (name password-entry-name)
  142. (password password-entry-password
  143. (serialization (const "x") (const #f))
  144. (default "x"))
  145. (uid password-entry-uid
  146. (serialization number->string string->number))
  147. (gid password-entry-gid
  148. (serialization number->string string->number))
  149. (real-name password-entry-real-name
  150. (default ""))
  151. (directory password-entry-directory)
  152. (shell password-entry-shell
  153. (default "/bin/sh")))
  154. (define-database-entry <shadow-entry> ;<shadow.h>
  155. shadow-entry make-shadow-entry
  156. shadow-entry?
  157. (serialization #\: shadow-entry->string string->shadow-entry)
  158. (name shadow-entry-name) ;string
  159. (password shadow-entry-password ;string | #f
  160. (serialization (string-if-false "!")
  161. (false-if-string=? "!"))
  162. (default #f))
  163. (last-change shadow-entry-last-change ;days since 1970-01-01
  164. (serialization number->string* string->number)
  165. (default 0))
  166. (minimum-change-period shadow-entry-minimum-change-period
  167. (serialization number->string* string->number)
  168. (default #f)) ;days | #f
  169. (maximum-change-period shadow-entry-maximum-change-period
  170. (serialization number->string* string->number)
  171. (default #f)) ;days | #f
  172. (change-warning-time shadow-entry-change-warning-time
  173. (serialization number->string* string->number)
  174. (default #f)) ;days | #f
  175. (maximum-inactivity shadow-entry-maximum-inactivity
  176. (serialization number->string* string->number)
  177. (default #f)) ;days | #f
  178. (expiration shadow-entry-expiration
  179. (serialization number->string* string->number)
  180. (default #f)) ;days since 1970-01-01 | #f
  181. (flags shadow-entry-flags ;"reserved"
  182. (serialization number->string* string->number)
  183. (default #f)))
  184. (define-database-entry <group-entry> ;<grp.h>
  185. group-entry make-group-entry
  186. group-entry?
  187. (serialization #\: group-entry->string string->group-entry)
  188. (name group-entry-name)
  189. (password group-entry-password
  190. (serialization (string-if-false "x")
  191. (false-if-string=? "x"))
  192. (default #f))
  193. (gid group-entry-gid
  194. (serialization number->string string->number))
  195. (members group-entry-members
  196. (serialization list->comma-separated comma-separated->list)
  197. (default '())))
  198. (define %password-lock-file
  199. ;; The password database lock file used by libc's 'lckpwdf'. Users should
  200. ;; grab this lock with 'with-file-lock' when they access the databases.
  201. "/etc/.pwd.lock")
  202. (define (database-writer file mode entry->string)
  203. (lambda* (entries #:optional (file-or-port file))
  204. "Write ENTRIES to FILE-OR-PORT. When FILE-OR-PORT is a file name, write
  205. to it atomically and set the appropriate permissions."
  206. (define (write-entries port)
  207. (for-each (lambda (entry)
  208. (display (entry->string entry) port)
  209. (newline port))
  210. (delete-duplicates entries)))
  211. (if (port? file-or-port)
  212. (write-entries file-or-port)
  213. (let* ((template (string-append file-or-port ".XXXXXX"))
  214. (port (mkstemp! template)))
  215. (dynamic-wind
  216. (const #t)
  217. (lambda ()
  218. (chmod port mode)
  219. (write-entries port)
  220. (fsync port)
  221. (close-port port)
  222. (rename-file template file-or-port))
  223. (lambda ()
  224. (unless (port-closed? port)
  225. (close-port port))
  226. (when (file-exists? template)
  227. (delete-file template))))))))
  228. (define write-passwd
  229. (database-writer "/etc/passwd" #o644 password-entry->string))
  230. (define write-shadow
  231. (database-writer "/etc/shadow" #o600 shadow-entry->string))
  232. (define write-group
  233. (database-writer "/etc/group" #o644 group-entry->string))
  234. (define (database-reader file string->entry)
  235. (lambda* (#:optional (file-or-port file))
  236. (define (read-entries port)
  237. (let loop ((entries '()))
  238. (match (read-line port)
  239. ((? eof-object?)
  240. (reverse entries))
  241. (line
  242. (loop (cons (string->entry line) entries))))))
  243. (if (port? file-or-port)
  244. (read-entries file-or-port)
  245. (call-with-input-file file-or-port
  246. read-entries))))
  247. (define read-passwd
  248. (database-reader "/etc/passwd" string->password-entry))
  249. (define read-shadow
  250. (database-reader "/etc/shadow" string->shadow-entry))
  251. (define read-group
  252. (database-reader "/etc/group" string->group-entry))
  253. ;;;
  254. ;;; Building databases.
  255. ;;;
  256. (define-record-type* <allocation>
  257. allocation make-allocation
  258. allocation?
  259. (ids allocation-ids (default vlist-null))
  260. (next-id allocation-next-id (default %id-min))
  261. (next-system-id allocation-next-system-id (default %system-id-max)))
  262. ;; Trick to avoid name clashes...
  263. (define-syntax %allocation (identifier-syntax allocation))
  264. ;; Minimum and maximum UIDs and GIDs (from find_new_uid.c and find_new_gid.c
  265. ;; in Shadow.)
  266. (define %id-min 1000)
  267. (define %id-max 60000)
  268. (define %system-id-min 100)
  269. (define %system-id-max 999)
  270. (define (system-id? id)
  271. (and (> id %system-id-min)
  272. (<= id %system-id-max)))
  273. (define (user-id? id)
  274. (and (>= id %id-min)
  275. (< id %id-max)))
  276. (define* (allocate-id assignment #:key system?)
  277. "Return two values: a newly allocated ID, and an updated <allocation> record
  278. based on ASSIGNMENT. If SYSTEM? is true, return a system ID."
  279. (define next
  280. ;; Return the next available ID, looping if necessary.
  281. (if system?
  282. (lambda (id)
  283. (let ((next-id (- id 1)))
  284. (if (< next-id %system-id-min)
  285. %system-id-max
  286. next-id)))
  287. (lambda (id)
  288. (let ((next-id (+ id 1)))
  289. (if (>= next-id %id-max)
  290. %id-min
  291. next-id)))))
  292. (let loop ((id (if system?
  293. (allocation-next-system-id assignment)
  294. (allocation-next-id assignment))))
  295. (if (vhash-assv id (allocation-ids assignment))
  296. (loop (next id))
  297. (let ((taken (vhash-consv id #t (allocation-ids assignment))))
  298. (values (if system?
  299. (allocation (inherit assignment)
  300. (next-system-id (next id))
  301. (ids taken))
  302. (allocation (inherit assignment)
  303. (next-id (next id))
  304. (ids taken)))
  305. id)))))
  306. (define* (reserve-ids allocation ids #:key (skip? #t))
  307. "Mark the numbers listed in IDS as reserved in ALLOCATION. When SKIP? is
  308. true, start allocation after the highest (or lowest, depending on whether it's
  309. a system ID allocation) number among IDS."
  310. (%allocation
  311. (inherit allocation)
  312. (next-id (if skip?
  313. (+ (reduce max
  314. (- (allocation-next-id allocation) 1)
  315. (filter user-id? ids))
  316. 1)
  317. (allocation-next-id allocation)))
  318. (next-system-id
  319. (if skip?
  320. (- (reduce min
  321. (+ 1 (allocation-next-system-id allocation))
  322. (filter system-id? ids))
  323. 1)
  324. (allocation-next-system-id allocation)))
  325. (ids (fold (cut vhash-consv <> #t <>)
  326. (allocation-ids allocation)
  327. ids))))
  328. (define (allocated? allocation id)
  329. "Return true if ID is already allocated as part of ALLOCATION."
  330. (->bool (vhash-assv id (allocation-ids allocation))))
  331. (define (lookup-procedure lst key)
  332. "Return a lookup procedure for the elements of LST, calling KEY to obtain
  333. the key of each element."
  334. (let ((table (fold (lambda (obj table)
  335. (vhash-cons (key obj) obj table))
  336. vlist-null
  337. lst)))
  338. (lambda (key)
  339. (match (vhash-assoc key table)
  340. (#f #f)
  341. ((_ . value) value)))))
  342. (define* (allocate-groups groups members
  343. #:optional (current-groups '()))
  344. "Return a list of group entries for GROUPS, a list of <user-group>. Members
  345. for each group are taken from MEMBERS, a vhash that maps group names to member
  346. names. GIDs and passwords found in CURRENT-GROUPS, a list of group entries,
  347. are reused."
  348. (define gids
  349. ;; Mark all the currently-used GIDs and the explicitly requested GIDs as
  350. ;; reserved.
  351. (reserve-ids (reserve-ids (allocation)
  352. (map group-entry-gid current-groups))
  353. (filter-map user-group-id groups)
  354. #:skip? #f))
  355. (define previous-entry
  356. (lookup-procedure current-groups group-entry-name))
  357. (reverse
  358. (fold2 (lambda (group result allocation)
  359. (let ((name (user-group-name group))
  360. (password (user-group-password group))
  361. (requested-id (user-group-id group))
  362. (system? (user-group-system? group)))
  363. (let*-values (((previous)
  364. (previous-entry name))
  365. ((allocation id)
  366. (cond
  367. ((number? requested-id)
  368. (values (reserve-ids allocation
  369. (list requested-id))
  370. requested-id))
  371. (previous
  372. (values allocation
  373. (group-entry-gid previous)))
  374. (else
  375. (allocate-id allocation
  376. #:system? system?)))))
  377. (values (cons (group-entry
  378. (name name)
  379. (password
  380. (if previous
  381. (group-entry-password previous)
  382. password))
  383. (gid id)
  384. (members (vhash-fold* cons '() name members)))
  385. result)
  386. allocation))))
  387. '()
  388. gids
  389. groups)))
  390. (define* (allocate-passwd users groups #:optional (current-passwd '()))
  391. "Return a list of password entries for USERS, a list of <user-account>.
  392. Take GIDs from GROUPS, a list of group entries. Reuse UIDs from
  393. CURRENT-PASSWD, a list of password entries, when possible; otherwise allocate
  394. new UIDs."
  395. (define uids
  396. (reserve-ids (reserve-ids (allocation)
  397. (map password-entry-uid current-passwd))
  398. (filter-map user-account-uid users)
  399. #:skip? #f))
  400. (define previous-entry
  401. (lookup-procedure current-passwd password-entry-name))
  402. (define (group-id name)
  403. (or (any (lambda (entry)
  404. (and (string=? (group-entry-name entry) name)
  405. (group-entry-gid entry)))
  406. groups)
  407. (error "group not found" name)))
  408. (reverse
  409. (fold2 (lambda (user result allocation)
  410. (let ((name (user-account-name user))
  411. (requested-id (user-account-uid user))
  412. (group (user-account-group user))
  413. (real-name (user-account-comment user))
  414. (directory (user-account-home-directory user))
  415. (shell (user-account-shell user))
  416. (system? (user-account-system? user)))
  417. (let*-values (((previous)
  418. (previous-entry name))
  419. ((allocation id)
  420. (cond
  421. ((number? requested-id)
  422. (values (reserve-ids allocation
  423. (list requested-id))
  424. requested-id))
  425. (previous
  426. (values allocation
  427. (password-entry-uid previous)))
  428. (else
  429. (allocate-id allocation
  430. #:system? system?)))))
  431. (values (cons (password-entry
  432. (name name)
  433. (uid id)
  434. (directory directory)
  435. (gid (if (number? group) group (group-id group)))
  436. (real-name (if previous
  437. (password-entry-real-name previous)
  438. real-name))
  439. ;; Do not reuse the shell of PREVIOUS since (1)
  440. ;; that could lead to confusion, and (2) the
  441. ;; shell might have been GC'd. See
  442. ;; <https://lists.gnu.org/archive/html/guix-devel/2019-04/msg00478.html>.
  443. (shell shell))
  444. result)
  445. allocation))))
  446. '()
  447. uids
  448. users)))
  449. (define* (days-since-epoch #:optional (current-time current-time))
  450. "Return the number of days elapsed since the 1st of January, 1970."
  451. (let* ((now (current-time time-utc))
  452. (epoch (make-time time-utc 0 0))
  453. (diff (time-difference now epoch)))
  454. (quotient (time-second diff) (* 24 3600))))
  455. (define* (passwd->shadow users passwd #:optional (current-shadow '())
  456. #:key (current-time current-time))
  457. "Return a list of shadow entries for the password entries listed in PASSWD.
  458. Reuse shadow entries from CURRENT-SHADOW when they exist, and take the initial
  459. password from USERS."
  460. (define previous-entry
  461. (lookup-procedure current-shadow shadow-entry-name))
  462. (define now
  463. (days-since-epoch current-time))
  464. (map (lambda (user passwd)
  465. (or (previous-entry (password-entry-name passwd))
  466. (shadow-entry (name (password-entry-name passwd))
  467. (password (user-account-password user))
  468. (last-change now))))
  469. users passwd))
  470. (define (empty-if-not-found thunk)
  471. "Call THUNK and return the empty list if that throws to ENOENT."
  472. (catch 'system-error
  473. thunk
  474. (lambda args
  475. (if (= ENOENT (system-error-errno args))
  476. '()
  477. (apply throw args)))))
  478. (define* (user+group-databases users groups
  479. #:key
  480. (current-passwd
  481. (empty-if-not-found read-passwd))
  482. (current-groups
  483. (empty-if-not-found read-group))
  484. (current-shadow
  485. (empty-if-not-found read-shadow))
  486. (current-time current-time))
  487. "Return three values: the list of group entries, the list of password
  488. entries, and the list of shadow entries corresponding to USERS and GROUPS.
  489. Preserve stateful bits from CURRENT-PASSWD, CURRENT-GROUPS, and
  490. CURRENT-SHADOW: UIDs, GIDs, passwords, user shells, etc."
  491. (define members
  492. ;; Map group name to user names.
  493. (fold (lambda (user members)
  494. (fold (cute vhash-cons <> (user-account-name user) <>)
  495. members
  496. (user-account-supplementary-groups user)))
  497. vlist-null
  498. users))
  499. (define group-entries
  500. (allocate-groups groups members current-groups))
  501. (define passwd-entries
  502. (allocate-passwd users group-entries current-passwd))
  503. (define shadow-entries
  504. (passwd->shadow users passwd-entries current-shadow
  505. #:current-time current-time))
  506. (values group-entries passwd-entries shadow-entries))