| 1 | |
| 2 | |
| 3 | |
| 4 | |
| 5 | |
| 6 | |
| 7 | |
| 8 | |
| 9 | |
| 10 | |
| 11 | |
| 12 | |
| 13 | |
| 14 | |
| 15 | |
| 16 | |
| 17 | |
| 18 | |
| 19 | |
| 20 |
|
| 21 | (define-module (gnu tests ssh)
|
| 22 | #:use-module (gnu tests)
|
| 23 | #:use-module (gnu system)
|
| 24 | #:use-module (gnu system vm)
|
| 25 | #:use-module (gnu services)
|
| 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)
|
| 31 | #:export (%test-openssh
|
| 32 | %test-dropbear))
|
| 33 |
|
| 34 | (define* (run-ssh-test name ssh-service pid-file
|
| 35 | #:key (sftp? #f) (test-getlogin? #t))
|
| 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
|
| 38 | empty-password logins.
|
| 39 |
|
| 40 | When SFTP? is true, run an SFTP server test."
|
| 41 | (define os
|
| 42 | (marionette-operating-system
|
| 43 | (simple-operating-system (service dhcpcd-service-type) ssh-service)
|
| 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))
|
| 53 | (with-extensions (list guile-ssh)
|
| 54 | #~(begin
|
| 55 | (use-modules (gnu build marionette)
|
| 56 | (srfi srfi-26)
|
| 57 | (srfi srfi-64)
|
| 58 | (ice-9 textual-ports)
|
| 59 | (ice-9 match)
|
| 60 | (ssh session)
|
| 61 | (ssh auth)
|
| 62 | (ssh channel)
|
| 63 | (ssh popen)
|
| 64 | (ssh sftp))
|
| 65 |
|
| 66 | (define marionette
|
| 67 | |
| 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
|
| 79 | connected SSH session object, return the result of the procedure call. The
|
| 80 | session is disconnected when the PROC is finished."
|
| 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
|
| 93 | root with an empty password."
|
| 94 | (call-with-connected-session
|
| 95 | (lambda (session)
|
| 96 | |
| 97 | |
| 98 | |
| 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 | (test-runner-current (system-test-runner #$output))
|
| 112 | (test-begin "ssh-daemon")
|
| 113 |
|
| 114 | |
| 115 | (test-assert "service running"
|
| 116 | (marionette-eval
|
| 117 | '(begin
|
| 118 | (use-modules (gnu services herd))
|
| 119 | (start-service 'ssh-daemon))
|
| 120 | marionette))
|
| 121 |
|
| 122 | |
| 123 | (test-assert "sshd PID"
|
| 124 | (let ((pid (marionette-eval
|
| 125 | '(begin
|
| 126 | (use-modules (gnu services herd)
|
| 127 | (srfi srfi-1)
|
| 128 | (ice-9 match))
|
| 129 |
|
| 130 | (match (live-service-running
|
| 131 | (find (lambda (live)
|
| 132 | (memq 'ssh-daemon
|
| 133 | (live-service-provision live)))
|
| 134 | (current-services)))
|
| 135 | ((? number? pid)
|
| 136 | |
| 137 | pid)
|
| 138 | (('inetd-service _ ...)
|
| 139 | #t)
|
| 140 | (('process ('version 0 _ ...)
|
| 141 | ('id pid) _ ...)
|
| 142 | pid)))
|
| 143 | marionette)))
|
| 144 | (if #$pid-file
|
| 145 | (= pid (wait-for-file #$pid-file marionette))
|
| 146 | pid)))
|
| 147 |
|
| 148 | (test-assert "wait for port 22, IPv4"
|
| 149 | (wait-for-tcp-port 22 marionette))
|
| 150 |
|
| 151 | (test-assert "wait for port 22, IPv6"
|
| 152 | |
| 153 | |
| 154 | (wait-for-tcp-port 22 marionette
|
| 155 | #:address
|
| 156 | `(make-socket-address
|
| 157 | AF_INET6
|
| 158 | (inet-pton AF_INET6 "::1")
|
| 159 | 22)))
|
| 160 |
|
| 161 | |
| 162 | |
| 163 | (test-equal "shell command"
|
| 164 | 'hello
|
| 165 | (call-with-connected-session/auth
|
| 166 | (lambda (session)
|
| 167 | |
| 168 | |
| 169 | (let ((channel (make-channel session)))
|
| 170 | (channel-open-session channel)
|
| 171 | (channel-request-exec channel "echo hello > /root/witness")
|
| 172 | (and (zero? (channel-get-exit-status channel))
|
| 173 | (wait-for-file "/root/witness" marionette))))))
|
| 174 |
|
| 175 | |
| 176 | (unless #$test-getlogin?
|
| 177 | (test-skip 1))
|
| 178 | (test-equal "getlogin"
|
| 179 | '(0 "root")
|
| 180 | (call-with-connected-session/auth
|
| 181 | (lambda (session)
|
| 182 | (let* ((pipe (open-remote-input-pipe
|
| 183 | session
|
| 184 | "guile -c '(display (getlogin))'"))
|
| 185 | (output (get-string-all pipe))
|
| 186 | (status (channel-get-exit-status pipe)))
|
| 187 | (list status output)))))
|
| 188 |
|
| 189 | |
| 190 | |
| 191 | (unless #$sftp?
|
| 192 | (test-skip 1))
|
| 193 | (test-equal "SFTP file writing and reading"
|
| 194 | 'hello
|
| 195 | (call-with-connected-session/auth
|
| 196 | (lambda (session)
|
| 197 | (let ((sftp-session (make-sftp-session session))
|
| 198 | (witness "/root/sftp-witness"))
|
| 199 | (call-with-remote-output-file sftp-session witness
|
| 200 | (cut display "hello" <>))
|
| 201 | (call-with-remote-input-file sftp-session witness
|
| 202 | read)))))
|
| 203 |
|
| 204 | |
| 205 | |
| 206 | (test-equal "run executables from system profile"
|
| 207 | #t
|
| 208 | (call-with-connected-session/auth
|
| 209 | (lambda (session)
|
| 210 | (let ((channel (make-channel session)))
|
| 211 | (channel-open-session channel)
|
| 212 | (channel-request-exec
|
| 213 | channel
|
| 214 | (string-append
|
| 215 | "mkdir -p /root/.guix-profile/bin && "
|
| 216 | "touch /root/.guix-profile/bin/path-witness && "
|
| 217 | "chmod 755 /root/.guix-profile/bin/path-witness"))
|
| 218 | (zero? (channel-get-exit-status channel))))))
|
| 219 |
|
| 220 | |
| 221 | |
| 222 | (test-equal "run executable from user profile"
|
| 223 | #t
|
| 224 | (call-with-connected-session/auth
|
| 225 | (lambda (session)
|
| 226 | (let ((channel (make-channel session)))
|
| 227 | (channel-open-session channel)
|
| 228 | (channel-request-exec channel "path-witness")
|
| 229 | (zero? (channel-get-exit-status channel))))))
|
| 230 |
|
| 231 | (test-end)))))
|
| 232 |
|
| 233 | (gexp->derivation name test))
|
| 234 |
|
| 235 | (define %test-openssh
|
| 236 | (system-test
|
| 237 | (name "openssh")
|
| 238 | (description "Connect to a running OpenSSH daemon.")
|
| 239 | (value (run-ssh-test name
|
| 240 | |
| 241 | |
| 242 | (service openssh-service-type
|
| 243 | (openssh-configuration
|
| 244 | (permit-root-login #t)
|
| 245 | (allow-empty-passwords? #t)))
|
| 246 | #f |
| 247 | #:sftp? #t))))
|
| 248 |
|
| 249 | (define %test-dropbear
|
| 250 | (system-test
|
| 251 | (name "dropbear")
|
| 252 | (description "Connect to a running Dropbear SSH daemon.")
|
| 253 | (value (run-ssh-test name
|
| 254 | (service dropbear-service-type
|
| 255 | (dropbear-configuration
|
| 256 | (root-login? #t)
|
| 257 | (allow-empty-passwords? #t)))
|
| 258 | "/var/run/dropbear.pid"
|
| 259 |
|
| 260 | |
| 261 | |
| 262 | |
| 263 | #:test-getlogin? #f))))
|