aboutsummaryrefslogtreecommitdiff
path: root/gnu/system/accounts.scm
blob: 586cff1842e3e8e6192ad62f52e5a3d2ef8b34fc (about) (plain)
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
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.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 system accounts)
  #:use-module (guix records)
  #:use-module (ice-9 match)
  #:export (user-account
            user-account?
            user-account-name
            user-account-password
            user-account-uid
            user-account-group
            user-account-supplementary-groups
            user-account-comment
            user-account-home-directory
            user-account-create-home-directory?
            user-account-shell
            user-account-system?

            user-group
            user-group?
            user-group-name
            user-group-password
            user-group-id
            user-group-system?

            sexp->user-account
            sexp->user-group

            default-shell))


;;; Commentary:
;;;
;;; Data structures representing user accounts and user groups.  This is meant
;;; to be used both on the host side and at run time--e.g., in activation
;;; snippets.
;;;
;;; Code:

(define default-shell
  ;; Default shell for user accounts (a string or string-valued gexp).
  (make-parameter "/bin/sh"))

(define-record-type* <user-account>
  user-account make-user-account
  user-account?
  (name           user-account-name)
  (password       user-account-password (default #f))
  (uid            user-account-uid (default #f))
  (group          user-account-group)             ; number | string
  (supplementary-groups user-account-supplementary-groups
                        (default '()))            ; list of strings
  (comment        user-account-comment (default ""))
  (home-directory user-account-home-directory (thunked)
                  (default (default-home-directory this-record)))
  (create-home-directory? user-account-create-home-directory? ;Boolean
                          (default #t))
  (shell          user-account-shell              ; gexp
                  (default (default-shell)))
  (system?        user-account-system?            ; Boolean
                  (default #f)))

(define-record-type* <user-group>
  user-group make-user-group
  user-group?
  (name           user-group-name)
  (password       user-group-password (default #f))
  (id             user-group-id (default #f))
  (system?        user-group-system?              ; Boolean
                  (default #f)))

(define (default-home-directory account)
  "Return the default home directory for ACCOUNT."
  (string-append "/home/" (user-account-name account)))

(define (sexp->user-group sexp)
  "Take SEXP, a tuple as returned by 'user-group->gexp', and turn it into a
user-group record."
  (match sexp
    ((name password id system?)
     (user-group (name name)
                 (password password)
                 (id id)
                 (system? system?)))))

(define (sexp->user-account sexp)
  "Take SEXP, a tuple as returned by 'user-account->gexp', and turn it into a
user-account record."
  (match sexp
    ((name uid group supplementary-groups comment home-directory
           create-home-directory? shell password system?)
     (user-account (name name) (uid uid) (group group)
                   (supplementary-groups supplementary-groups)
                   (comment comment)
                   (home-directory home-directory)
                   (create-home-directory? create-home-directory?)
                   (shell shell) (password password)
                   (system? system?)))))
-syntax ((verify (syntax-rules () ((_) '()) ((_ (new old ...) rest ...) (cons `(new old ... => ,(commit-descendant? new (list old ...))) (verify rest ...)))))) (verify (master3 master3) (master1 master3) (master3 master1) (master2 branch1) (master2 branch1 master1) (branch1 master2) (branch1 merge) (merge branch1) (master1 merge) (merge master1))))))) (test-equal "remote-refs" '("refs/heads/develop" "refs/heads/master" "refs/tags/v1.0" "refs/tags/v1.1") (with-temporary-git-repository directory '((add "a.txt" "A") (commit "First commit") (tag "v1.0" "release-1.0") (branch "develop") (checkout "develop") (add "b.txt" "B") (commit "Second commit") (tag "v1.1" "release-1.1")) (remote-refs directory))) (test-equal "remote-refs: only tags" '("refs/tags/v1.0" "refs/tags/v1.1") (with-temporary-git-repository directory '((add "a.txt" "A") (commit "First commit") (tag "v1.0" "Release 1.0") (add "b.txt" "B") (commit "Second commit") (tag "v1.1" "Release 1.1")) (remote-refs directory #:tags? #t))) (test-assert "update-cached-checkout, tag" (call-with-temporary-directory (lambda (cache) (with-temporary-git-repository directory '((add "a.txt" "A") (commit "First commit") (tag "v1.0" "release-1.0") (branch "develop") (checkout "develop") (add "b.txt" "B") (commit "Second commit") (tag "v1.1" "release-1.1")) (let ((directory commit relation (update-cached-checkout directory #:ref '(tag . "v1.1") #:cache-directory cache)) (head (let* ((pipe (open-pipe* OPEN_READ (git-command) "-C" directory "rev-parse" "HEAD")) (str (get-string-all pipe))) (close-pipe pipe) (string-trim-right str)))) ;; COMMIT should be the ID of the commit object, not that of the tag. (string=? commit head)))))) (test-assert "update-cached-checkout, untracked files removed" (call-with-temporary-directory (lambda (cache) (with-temporary-git-repository directory '((add "a.txt" "A") (add ".gitignore" ".~\n") (commit "First commit")) (let ((directory commit relation (update-cached-checkout directory #:ref '() #:cache-directory cache))) (close-port (open-output-file (in-vicinity cache "stale-untracked-file"))) (let ((directory2 commit2 relation2 (update-cached-checkout directory #:ref '() #:cache-directory cache))) (not (file-exists? (in-vicinity cache "stale-untracked-file"))))))))) (test-end "git")