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
| | ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015 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 (test-syscalls)
#:use-module (guix build syscalls)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
#:use-module (ice-9 match)
#:use-module ((ice-9 popen) #:select (open-pipe*))
#:use-module ((ice-9 rdelim) #:select (read-line))
#:use-module ((ice-9 regex) #:select (string-match match:substring))
#:use-module (rnrs bytevectors)
#:use-module (system foreign)
#:use-module ((rnrs io ports) #:select (port-eof?)))
;; Test the (guix build syscalls) module, although there's not much that can
;; actually be tested without being root.
;; Is the first character of a string #\space?
(define-syntax-rule (first-char-is-space? string)
(eq? #\space (string-ref string 0)))
;; In the output produced by ifconfig (8), is a line
;; one that starts a new interface description?
(define-syntax-rule (line-contains-iface-name? line)
(not (or (string-null? line)
(first-char-is-space? line))))
(define (ifconfig-find-all-interfaces)
"List all the network interfaces as identified
by ifconfig (8)."
(let ((pipe (open-pipe* OPEN_READ "ifconfig")))
(let lp ((line (read-line pipe))
(res '()))
(cond ((port-eof? pipe) (reverse res))
((line-contains-iface-name? line)
(let* ((trimmed-line (string-trim-both line))
(split-line (string-split trimmed-line #\space))
(iface-name (car split-line)))
(lp (read-line pipe)
(cons iface-name res))))
(else (lp (read-line pipe) res))))))
(define (extract-iface-name line)
"Extract the name of the interface from a line in the output of
ifconfig (8) which is known to be the first line describing said
interface."
(let ((str-ls (string->list line)))
(let lp ((ls str-ls) (res '()))
(if (eq? #\space (car ls))
(apply string (reverse res))
(lp (cdr ls) (cons (car ls) res))))))
(define (ifconfig-extract-addr-of iface-name type)
"Call ifconfig (8) to find out the broadcast address of the
interface whose name is a prefix of the string IFACE-NAME. The
broadcast address is returned as a printable string."
(let ((pipe (open-pipe* OPEN_READ "ifconfig")))
(let lp ((line (read-line pipe)))
(if (eof-object? line)
#f
(if (and (line-contains-iface-name? line)
(string-prefix? iface-name
(extract-iface-name line)))
(let* ((next-line (read-line pipe))
(search-string (cond ((eq? type 'broadcast) "Bcast:")
((eq? type 'netmask) "Mask:")
(else "inet addr:")))
(str-byte "[0-9]([0-9][0-9])?")
(ipaddr-regex (string-append search-string
str-byte "\\."
str-byte "\\."
str-byte "\\."
str-byte))
(match (string-match ipaddr-regex next-line)))
(if match
(string-drop (match:substring match) (cond ((eq? type 'broadcast) 6)
((eq? type 'netmask) 5)
(else 10)))
(lp (read-line pipe))))
(lp (read-line pipe)))))))
(define (prefix? ls1 ls2)
"Is list LS1 a prefix of list LS2?. This procedure
assumes that (length ls1) <= (length ls2)."
(or (null? ls1)
(and (equal? (car ls1) (car ls2))
(prefix? (cdr ls1) (cdr ls2)))))
(define (remove-duplicates ls)
"Remove consecutive duplicate elements from a list LS.
For example, (4 2 2 2 2 1 3 3) => (4 2 1 3)."
(cond ((< (length ls) 2)
ls)
((equal? (car ls) (cadr ls))
(remove-duplicates (cdr ls)))
(else
(cons (car ls) (remove-duplicates (cdr ls))))))
(test-begin "syscalls")
(test-equal "mount, ENOENT"
ENOENT
(catch 'system-error
(lambda ()
(mount "/dev/null" "/does-not-exist" "ext2")
#f)
(compose system-error-errno list)))
(test-assert "umount, ENOENT/EPERM"
(catch 'system-error
(lambda ()
(umount "/does-not-exist")
#f)
(lambda args
;; Both return values have been encountered in the wild.
(memv (system-error-errno args) (list EPERM ENOENT)))))
(test-assert "mount-points"
;; Reportedly "/" is not always listed as a mount point, so check a few
;; others (see <http://bugs.gnu.org/20261>.)
(any (cute member <> (mount-points))
'("/" "/proc" "/sys" "/dev")))
(test-assert "swapon, ENOENT/EPERM"
(catch 'system-error
(lambda ()
(swapon "/does-not-exist")
#f)
(lambda args
(memv (system-error-errno args) (list EPERM ENOENT)))))
(test-assert "swapoff, ENOENT/EINVAL/EPERM"
(catch 'system-error
(lambda ()
(swapoff "/does-not-exist")
#f)
(lambda args
(memv (system-error-errno args) (list EPERM EINVAL ENOENT)))))
(test-assert "all-network-interfaces"
(match (all-network-interfaces)
(((? string? names) ..1)
(member "lo" names))))
(test-assert "network-interfaces"
(match (network-interfaces)
(((? string? names) ..1)
(lset<= string=? names (all-network-interfaces)))))
(test-assert "network-interface-flags"
(let* ((sock (socket AF_INET SOCK_STREAM 0))
(flags (network-interface-flags sock "lo")))
(close-port sock)
(and (not (zero? (logand flags IFF_LOOPBACK)))
(not (zero? (logand flags IFF_UP))))))
(test-equal "loopback-network-interface?"
ENODEV
(and (loopback-network-interface? "lo")
(catch 'system-error
(lambda ()
(loopback-network-interface? "nonexistent")
#f)
(lambda args
(system-error-errno args)))))
(test-skip (if (zero? (getuid)) 1 0))
(test-assert "set-network-interface-flags"
(let ((sock (socket AF_INET SOCK_STREAM 0)))
(catch 'system-error
(lambda ()
(set-network-interface-flags sock "lo" IFF_UP))
(lambda args
(close-port sock)
;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
(memv (system-error-errno args) (list EPERM EACCES))))))
(test-equal "network-interface-address lo"
(make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0)
(let* ((sock (socket AF_INET SOCK_STREAM 0))
(addr (network-interface-address sock "lo")))
(close-port sock)
addr))
(test-assert "set-network-interface-address"
(let ((sock (socket AF_INET SOCK_STREAM 0)))
(catch 'system-error
(lambda ()
(set-network-interface-address sock "nonexistent"
(make-socket-address
AF_INET
(inet-pton AF_INET "127.12.14.15")
0)))
(lambda args
(close-port sock)
;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
(memv (system-error-errno args) (list EPERM EACCES))))))
(test-end)
\f
(exit (= (test-runner-fail-count (test-runner-current)) 0))
|