forked from philhofer/distill
-
Notifications
You must be signed in to change notification settings - Fork 0
/
unix.scm
128 lines (120 loc) · 4.35 KB
/
unix.scm
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
(define-kvector-type
<user>
make-user
user?
(user-name name: #f symbol?)
(user-uid uid: #f fixnum?)
(user-gid gid: #f fixnum?)
(user-home home: "/var/empty" string?)
(user-login login: "/sbin/nologin" string?))
(define-kvector-type
<group>
make-group
group?
(group-name name: #f symbol?)
(group-gid gid: #f fixnum?)
(group-users users: '() (list-of symbol?)))
(: base-users (list-of vector))
(define base-users
(map
(cut apply make-user <>)
'((name: root uid: 0 gid: 0 home: "/root" login: "/bin/ash")
(name: nobody uid: 65534 gid: 65534 home: "/" login: "/sbin/nologin")
(name: catchlog uid: 99 gid: 99 home: "/" login: "/sbin/nologin"))))
(: base-groups (list-of vector))
(define base-groups
(map
(cut apply make-group <>)
'((name: root gid: 0 users: (root))
(name: nobody gid: 65534 users: (nobody))
(name: catchlog gid: 99 users: (catchlog)))))
(define (adduser name #!key
(group #f)
(home "/var/empty")
(login "/sbin/nologin"))
(lambda (uid getgroup)
(make-user
name: name
uid: uid
gid: (if group (getgroup group) uid)
home: home
login: login)))
(define (addgroup name users)
(lambda (gid)
(make-group
name: name
gid: gid
users: users)))
;; groups+users->artifacts takes a list
;; of addgroup expressions and a list of
;; adduser expressions and returns a list
;; of artifacts for /etc/passwd, /etc/group, and so forth
;;
;; the groups and users lists can either be
;; the result of the 'adduser' or 'addgroup'
;; functions, respectively, or they can be
;; the result of make-user and make-group,
;; respectively
(define (groups+users->artifacts gps ups #!key
(start-uid 100)
(start-gid 100))
(let* ((ht (make-hash-table test: eq? hash: eq?-hash))
(getgroup (lambda (name)
(if (integer? name)
name
(hash-table-ref ht name))))
(groups (let loop ((in gps)
(out '())
(gid start-gid))
(if (null? in)
out
(let ((head (car in)))
(if (group? head)
(begin
(hash-table-set! ht (group-name head) (group-gid head))
(loop (cdr in) (cons head out) gid))
(let ((g ((car in) gid)))
(hash-table-set! ht (group-name g) gid)
(loop (cdr in) (cons g out) (+ 1 gid))))))))
(users (let loop ((in ups)
(out '())
(uid start-uid))
(if (null? in)
out
(let ((head (car in)))
(cond
((user? head)
(loop (cdr in) (cons head out) uid))
((procedure? head)
(loop (cdr in) (cons (head uid getgroup) out) (+ 1 uid)))
(else (error "bad user spec" head))))))))
(list
(etc/passwd (append base-users users))
(etc/group (append base-groups groups)))))
;; etc/passwd produces the artifact for /etc/passwd
;; given a list of users
(: etc/passwd ((list-of vector) --> vector))
(define (etc/passwd users)
(let ((usr->line (lambda (u)
(list
(user-name u)
"x"
(user-uid u)
(user-gid u)
""
(user-home u)
(user-login u)))))
(interned "/etc/passwd"
#o644
(tabular usr->line ":" "\n" users))))
(: etc/group ((list-of vector) --> vector))
(define (etc/group groups)
(let ((grp->line (lambda (g)
(list
(group-name g)
"x"
(number->string (group-gid g))
(join-with "," (group-users g))))))
(interned "/etc/group"
#o644
(tabular grp->line ":" "\n" groups))))