Commit | Line | Data |
---|---|---|
d5b0c902 | 1 | ;;; GNU Guix --- Functional package management for GNU |
a295a1ca | 2 | ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
c24b1547 | 3 | ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> |
5d7141cd | 4 | ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> |
d5b0c902 LC |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (gnu tests ssh) | |
22 | #:use-module (gnu tests) | |
23 | #:use-module (gnu system) | |
d5b0c902 LC |
24 | #:use-module (gnu system vm) |
25 | #:use-module (gnu services) | |
d5b0c902 LC |
26 | #:use-module (gnu services ssh) |
27 | #:use-module (gnu services networking) | |
28 | #:use-module (gnu packages ssh) | |
29 | #:use-module (guix gexp) | |
30 | #:use-module (guix store) | |
2b436389 LC |
31 | #:export (%test-openssh |
32 | %test-dropbear)) | |
d5b0c902 | 33 | |
e6b1a224 LC |
34 | (define* (run-ssh-test name ssh-service pid-file |
35 | #:key (sftp? #f) (test-getlogin? #t)) | |
0e598850 LC |
36 | "Run a test of an OS running SSH-SERVICE, which writes its PID to PID-FILE. |
37 | SSH-SERVICE must be configured to listen on port 22 and to allow for root and | |
36f666c6 CL |
38 | empty-password logins. |
39 | ||
40 | When SFTP? is true, run an SFTP server test." | |
8b113790 LC |
41 | (define os |
42 | (marionette-operating-system | |
39d7fdce | 43 | (simple-operating-system (service dhcp-client-service-type) ssh-service) |
8b113790 LC |
44 | #:imported-modules '((gnu services herd) |
45 | (guix combinators)))) | |
46 | (define vm | |
47 | (virtual-machine | |
48 | (operating-system os) | |
49 | (port-forwardings '((2222 . 22))))) | |
50 | ||
51 | (define test | |
52 | (with-imported-modules '((gnu build marionette)) | |
ff913cf5 LC |
53 | (with-extensions (list guile-ssh) |
54 | #~(begin | |
55 | (use-modules (gnu build marionette) | |
56 | (srfi srfi-26) | |
57 | (srfi srfi-64) | |
e6b1a224 | 58 | (ice-9 textual-ports) |
ff913cf5 LC |
59 | (ice-9 match) |
60 | (ssh session) | |
61 | (ssh auth) | |
62 | (ssh channel) | |
e6b1a224 | 63 | (ssh popen) |
ff913cf5 LC |
64 | (ssh sftp)) |
65 | ||
66 | (define marionette | |
67 | ;; Enable TCP forwarding of the guest's port 22. | |
68 | (make-marionette (list #$vm))) | |
69 | ||
70 | (define (make-session-for-test) | |
71 | "Make a session with predefined parameters for a test." | |
72 | (make-session #:user "root" | |
73 | #:port 2222 | |
74 | #:host "localhost" | |
75 | #:log-verbosity 'protocol)) | |
76 | ||
77 | (define (call-with-connected-session proc) | |
78 | "Call the one-argument procedure PROC with a freshly created and | |
cfaf4d11 CL |
79 | connected SSH session object, return the result of the procedure call. The |
80 | session is disconnected when the PROC is finished." | |
ff913cf5 LC |
81 | (let ((session (make-session-for-test))) |
82 | (dynamic-wind | |
83 | (lambda () | |
84 | (let ((result (connect! session))) | |
85 | (unless (equal? result 'ok) | |
86 | (error "Could not connect to a server" | |
87 | session result)))) | |
88 | (lambda () (proc session)) | |
89 | (lambda () (disconnect! session))))) | |
90 | ||
91 | (define (call-with-connected-session/auth proc) | |
92 | "Make an authenticated session. We should be able to connect as | |
cfaf4d11 | 93 | root with an empty password." |
ff913cf5 LC |
94 | (call-with-connected-session |
95 | (lambda (session) | |
96 | ;; Try the simple authentication methods. Dropbear requires | |
97 | ;; 'none' when there are no passwords, whereas OpenSSH accepts | |
98 | ;; 'password' with an empty password. | |
99 | (let loop ((methods (list (cut userauth-password! <> "") | |
100 | (cut userauth-none! <>)))) | |
101 | (match methods | |
102 | (() | |
103 | (error "all the authentication methods failed")) | |
104 | ((auth rest ...) | |
105 | (match (pk 'auth (auth session)) | |
106 | ('success | |
107 | (proc session)) | |
108 | ('denied | |
109 | (loop rest))))))))) | |
110 | ||
111 | (mkdir #$output) | |
112 | (chdir #$output) | |
113 | ||
114 | (test-begin "ssh-daemon") | |
115 | ||
116 | ;; Wait for sshd to be up and running. | |
c24b1547 | 117 | (test-assert "service running" |
ff913cf5 LC |
118 | (marionette-eval |
119 | '(begin | |
120 | (use-modules (gnu services herd)) | |
c24b1547 | 121 | (start-service 'ssh-daemon)) |
ff913cf5 LC |
122 | marionette)) |
123 | ||
124 | ;; Check sshd's PID file. | |
125 | (test-equal "sshd PID" | |
126 | (wait-for-file #$pid-file marionette) | |
127 | (marionette-eval | |
128 | '(begin | |
129 | (use-modules (gnu services herd) | |
130 | (srfi srfi-1)) | |
131 | ||
132 | (live-service-running | |
133 | (find (lambda (live) | |
134 | (memq 'ssh-daemon | |
135 | (live-service-provision live))) | |
136 | (current-services)))) | |
137 | marionette)) | |
138 | ||
a295a1ca LC |
139 | (test-assert "wait for port 22" |
140 | (wait-for-tcp-port 22 marionette)) | |
141 | ||
ff913cf5 LC |
142 | ;; Connect to the guest over SSH. Make sure we can run a shell |
143 | ;; command there. | |
144 | (test-equal "shell command" | |
145 | 'hello | |
146 | (call-with-connected-session/auth | |
147 | (lambda (session) | |
148 | ;; FIXME: 'get-server-public-key' segfaults. | |
149 | ;; (get-server-public-key session) | |
150 | (let ((channel (make-channel session))) | |
151 | (channel-open-session channel) | |
152 | (channel-request-exec channel "echo hello > /root/witness") | |
153 | (and (zero? (channel-get-exit-status channel)) | |
154 | (wait-for-file "/root/witness" marionette)))))) | |
155 | ||
e6b1a224 LC |
156 | ;; Check whether the 'getlogin' procedure returns the right thing. |
157 | (unless #$test-getlogin? | |
158 | (test-skip 1)) | |
159 | (test-equal "getlogin" | |
160 | '(0 "root") | |
161 | (call-with-connected-session/auth | |
162 | (lambda (session) | |
163 | (let* ((pipe (open-remote-input-pipe | |
164 | session | |
165 | "guile -c '(display (getlogin))'")) | |
166 | (output (get-string-all pipe)) | |
167 | (status (channel-get-exit-status pipe))) | |
168 | (list status output))))) | |
169 | ||
ff913cf5 LC |
170 | ;; Connect to the guest over SFTP. Make sure we can write and |
171 | ;; read a file there. | |
172 | (unless #$sftp? | |
173 | (test-skip 1)) | |
174 | (test-equal "SFTP file writing and reading" | |
175 | 'hello | |
176 | (call-with-connected-session/auth | |
177 | (lambda (session) | |
178 | (let ((sftp-session (make-sftp-session session)) | |
179 | (witness "/root/sftp-witness")) | |
180 | (call-with-remote-output-file sftp-session witness | |
181 | (cut display "hello" <>)) | |
182 | (call-with-remote-input-file sftp-session witness | |
183 | read))))) | |
184 | ||
185 | ;; Connect to the guest over SSH. Make sure we can run commands | |
186 | ;; from the system profile. | |
187 | (test-equal "run executables from system profile" | |
188 | #t | |
189 | (call-with-connected-session/auth | |
190 | (lambda (session) | |
191 | (let ((channel (make-channel session))) | |
192 | (channel-open-session channel) | |
193 | (channel-request-exec | |
194 | channel | |
195 | (string-append | |
196 | "mkdir -p /root/.guix-profile/bin && " | |
197 | "touch /root/.guix-profile/bin/path-witness && " | |
198 | "chmod 755 /root/.guix-profile/bin/path-witness")) | |
199 | (zero? (channel-get-exit-status channel)))))) | |
200 | ||
201 | ;; Connect to the guest over SSH. Make sure we can run commands | |
202 | ;; from the user profile. | |
203 | (test-equal "run executable from user profile" | |
204 | #t | |
205 | (call-with-connected-session/auth | |
206 | (lambda (session) | |
207 | (let ((channel (make-channel session))) | |
208 | (channel-open-session channel) | |
209 | (channel-request-exec channel "path-witness") | |
210 | (zero? (channel-get-exit-status channel)))))) | |
211 | ||
212 | (test-end) | |
213 | (exit (= (test-runner-fail-count (test-runner-current)) 0)))))) | |
8b113790 LC |
214 | |
215 | (gexp->derivation name test)) | |
d5b0c902 LC |
216 | |
217 | (define %test-openssh | |
218 | (system-test | |
219 | (name "openssh") | |
220 | (description "Connect to a running OpenSSH daemon.") | |
0e598850 LC |
221 | (value (run-ssh-test name |
222 | ;; Allow root logins with an empty password to | |
223 | ;; simplify testing. | |
224 | (service openssh-service-type | |
225 | (openssh-configuration | |
226 | (permit-root-login #t) | |
227 | (allow-empty-passwords? #t))) | |
36f666c6 CL |
228 | "/var/run/sshd.pid" |
229 | #:sftp? #t)))) | |
2b436389 LC |
230 | |
231 | (define %test-dropbear | |
232 | (system-test | |
233 | (name "dropbear") | |
234 | (description "Connect to a running Dropbear SSH daemon.") | |
235 | (value (run-ssh-test name | |
236 | (service dropbear-service-type | |
237 | (dropbear-configuration | |
238 | (root-login? #t) | |
239 | (allow-empty-passwords? #t))) | |
e6b1a224 LC |
240 | "/var/run/dropbear.pid" |
241 | ||
242 | ;; XXX: Our Dropbear is not built with PAM support. | |
243 | ;; Even when it is, it seems to ignore the PAM | |
244 | ;; 'session' requirements. | |
245 | #:test-getlogin? #f)))) |