Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

481 lines
20 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (gnu machine ssh)
  19. #:use-module (gnu bootloader)
  20. #:use-module (gnu machine)
  21. #:autoload (gnu packages gnupg) (guile-gcrypt)
  22. #:use-module (gnu system)
  23. #:use-module (gnu system file-systems)
  24. #:use-module (gnu system uuid)
  25. #:use-module (guix diagnostics)
  26. #:use-module (guix gexp)
  27. #:use-module (guix i18n)
  28. #:use-module (guix modules)
  29. #:use-module (guix monads)
  30. #:use-module (guix pki)
  31. #:use-module (guix records)
  32. #:use-module (guix remote)
  33. #:use-module (guix scripts system reconfigure)
  34. #:use-module (guix ssh)
  35. #:use-module (guix store)
  36. #:use-module (guix utils)
  37. #:use-module (gcrypt pk-crypto)
  38. #:use-module (ice-9 match)
  39. #:use-module (ice-9 textual-ports)
  40. #:use-module (srfi srfi-1)
  41. #:use-module (srfi srfi-19)
  42. #:use-module (srfi srfi-26)
  43. #:use-module (srfi srfi-34)
  44. #:use-module (srfi srfi-35)
  45. #:export (managed-host-environment-type
  46. machine-ssh-configuration
  47. machine-ssh-configuration?
  48. machine-ssh-configuration
  49. machine-ssh-configuration-host-name
  50. machine-ssh-configuration-build-locally?
  51. machine-ssh-configuration-authorize?
  52. machine-ssh-configuration-port
  53. machine-ssh-configuration-user
  54. machine-ssh-configuration-host-key
  55. machine-ssh-configuration-session))
  56. ;;; Commentary:
  57. ;;;
  58. ;;; This module implements remote evaluation and system deployment for
  59. ;;; machines that are accessible over SSH and have a known host-name. In the
  60. ;;; sense of the broader "machine" interface, we describe the environment for
  61. ;;; such machines as 'managed-host.
  62. ;;;
  63. ;;; Code:
  64. ;;;
  65. ;;; Parameters for the SSH client.
  66. ;;;
  67. (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
  68. make-machine-ssh-configuration
  69. machine-ssh-configuration?
  70. (host-name machine-ssh-configuration-host-name) ; string
  71. (system machine-ssh-configuration-system) ; string
  72. (build-locally? machine-ssh-configuration-build-locally? ; boolean
  73. (default #t))
  74. (authorize? machine-ssh-configuration-authorize? ; boolean
  75. (default #t))
  76. (port machine-ssh-configuration-port ; integer
  77. (default 22))
  78. (user machine-ssh-configuration-user ; string
  79. (default "root"))
  80. (identity machine-ssh-configuration-identity ; path to a private key
  81. (default #f))
  82. (session machine-ssh-configuration-session ; session
  83. (default #f))
  84. (host-key machine-ssh-configuration-host-key ; #f | string
  85. (default #f)))
  86. (define (machine-ssh-session machine)
  87. "Return the SSH session that was given in MACHINE's configuration, or create
  88. one from the configuration's parameters if one was not provided."
  89. (maybe-raise-unsupported-configuration-error machine)
  90. (let ((config (machine-configuration machine)))
  91. (or (machine-ssh-configuration-session config)
  92. (let ((host-name (machine-ssh-configuration-host-name config))
  93. (user (machine-ssh-configuration-user config))
  94. (port (machine-ssh-configuration-port config))
  95. (identity (machine-ssh-configuration-identity config))
  96. (host-key (machine-ssh-configuration-host-key config)))
  97. (unless host-key
  98. (warning (G_ "<machine-ssh-configuration> without a 'host-key' \
  99. is deprecated~%")))
  100. (open-ssh-session host-name
  101. #:user user
  102. #:port port
  103. #:identity identity
  104. #:host-key host-key)))))
  105. ;;;
  106. ;;; Remote evaluation.
  107. ;;;
  108. (define (machine-become-command machine)
  109. "Return as a list of strings the program and arguments necessary to run a
  110. shell command with escalated privileges for MACHINE's configuration."
  111. (if (string= "root" (machine-ssh-configuration-user
  112. (machine-configuration machine)))
  113. '()
  114. '("/run/setuid-programs/sudo" "-n" "--")))
  115. (define (managed-host-remote-eval machine exp)
  116. "Internal implementation of 'machine-remote-eval' for MACHINE instances with
  117. an environment type of 'managed-host."
  118. (maybe-raise-unsupported-configuration-error machine)
  119. (let ((config (machine-configuration machine)))
  120. (remote-eval exp (machine-ssh-session machine)
  121. #:build-locally?
  122. (machine-ssh-configuration-build-locally? config)
  123. #:system
  124. (machine-ssh-configuration-system config)
  125. #:become-command
  126. (machine-become-command machine))))
  127. ;;;
  128. ;;; Safety checks.
  129. ;;;
  130. (define (machine-check-file-system-availability machine)
  131. "Raise a '&message' error condition if any of the file-systems specified in
  132. MACHINE's 'system' declaration do not exist on the machine."
  133. (define file-systems
  134. (filter (lambda (fs)
  135. (and (file-system-mount? fs)
  136. (not (member (file-system-type fs)
  137. %pseudo-file-system-types))
  138. (not (memq 'bind-mount (file-system-flags fs)))))
  139. (operating-system-file-systems (machine-operating-system machine))))
  140. (define (check-literal-file-system fs)
  141. (define remote-exp
  142. #~(catch 'system-error
  143. (lambda ()
  144. (stat #$(file-system-device fs))
  145. #t)
  146. (lambda args
  147. (system-error-errno args))))
  148. (mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
  149. (when (number? errno)
  150. (raise (condition
  151. (&message
  152. (message (format #f (G_ "device '~a' not found: ~a")
  153. (file-system-device fs)
  154. (strerror errno)))))))
  155. (return #t)))
  156. (define (check-labeled-file-system fs)
  157. (define remote-exp
  158. (with-imported-modules (source-module-closure
  159. '((gnu build file-systems)))
  160. #~(begin
  161. (use-modules (gnu build file-systems))
  162. (find-partition-by-label #$(file-system-label->string
  163. (file-system-device fs))))))
  164. (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
  165. (unless result
  166. (raise (condition
  167. (&message
  168. (message (format #f (G_ "no file system with label '~a'")
  169. (file-system-label->string
  170. (file-system-device fs))))))))
  171. (return #t)))
  172. (define (check-uuid-file-system fs)
  173. (define remote-exp
  174. (with-imported-modules (source-module-closure
  175. '((gnu build file-systems)
  176. (gnu system uuid)))
  177. #~(begin
  178. (use-modules (gnu build file-systems)
  179. (gnu system uuid))
  180. (define uuid
  181. (string->uuid #$(uuid->string (file-system-device fs))))
  182. (find-partition-by-uuid uuid))))
  183. (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
  184. (unless result
  185. (raise (condition
  186. (&message
  187. (message (format #f (G_ "no file system with UUID '~a'")
  188. (uuid->string (file-system-device fs))))))))
  189. (return #t)))
  190. (mbegin %store-monad
  191. (mapm %store-monad check-literal-file-system
  192. (filter (lambda (fs)
  193. (string? (file-system-device fs)))
  194. file-systems))
  195. (mapm %store-monad check-labeled-file-system
  196. (filter (lambda (fs)
  197. (file-system-label? (file-system-device fs)))
  198. file-systems))
  199. (mapm %store-monad check-uuid-file-system
  200. (filter (lambda (fs)
  201. (uuid? (file-system-device fs)))
  202. file-systems))))
  203. (define (machine-check-initrd-modules machine)
  204. "Raise a '&message' error condition if any of the modules needed by
  205. 'needed-for-boot' file systems in MACHINE are not available in the initrd."
  206. (define file-systems
  207. (filter file-system-needed-for-boot?
  208. (operating-system-file-systems (machine-operating-system machine))))
  209. (define (missing-modules fs)
  210. (define remote-exp
  211. (let ((device (file-system-device fs)))
  212. (with-imported-modules (source-module-closure
  213. '((gnu build file-systems)
  214. (gnu build linux-modules)
  215. (gnu system uuid)))
  216. #~(begin
  217. (use-modules (gnu build file-systems)
  218. (gnu build linux-modules)
  219. (gnu system uuid))
  220. (define dev
  221. #$(cond ((string? device) device)
  222. ((uuid? device) #~(find-partition-by-uuid
  223. (string->uuid
  224. #$(uuid->string device))))
  225. ((file-system-label? device)
  226. #~(find-partition-by-label
  227. #$(file-system-label->string device)))))
  228. (missing-modules dev '#$(operating-system-initrd-modules
  229. (machine-operating-system machine)))))))
  230. (mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
  231. (return (list fs missing))))
  232. (mlet %store-monad ((device (mapm %store-monad missing-modules file-systems)))
  233. (for-each (match-lambda
  234. ((fs missing)
  235. (unless (null? missing)
  236. (raise (condition
  237. (&message
  238. (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
  239. (file-system-device fs)
  240. missing))))))))
  241. device)
  242. (return #t)))
  243. (define (machine-check-building-for-appropriate-system machine)
  244. "Raise a '&message' error condition if MACHINE is configured to be built
  245. locally and the 'system' field does not match the '%current-system' reported
  246. by MACHINE."
  247. (let ((config (machine-configuration machine))
  248. (system (remote-system (machine-ssh-session machine))))
  249. (when (and (machine-ssh-configuration-build-locally? config)
  250. (not (string= system (machine-ssh-configuration-system config))))
  251. (raise (condition
  252. (&message
  253. (message (format #f (G_ "incorrect target system \
  254. ('~a' was given, while the system reports that it is '~a')~%")
  255. (machine-ssh-configuration-system config)
  256. system)))))))
  257. (with-monad %store-monad (return #t)))
  258. (define (check-deployment-sanity machine)
  259. "Raise a '&message' error condition if it is clear that deploying MACHINE's
  260. 'system' declaration would fail."
  261. ;; Order is important here -- an incorrect value for 'system' will cause
  262. ;; invocations of 'remote-eval' to fail.
  263. (mbegin %store-monad
  264. (machine-check-building-for-appropriate-system machine)
  265. (machine-check-file-system-availability machine)
  266. (machine-check-initrd-modules machine)))
  267. ;;;
  268. ;;; System deployment.
  269. ;;;
  270. (define (machine-boot-parameters machine)
  271. "Monadic procedure returning a list of 'boot-parameters' for the generations
  272. of MACHINE's system profile, ordered from most recent to oldest."
  273. (define bootable-kernel-arguments
  274. (@@ (gnu system) bootable-kernel-arguments))
  275. (define remote-exp
  276. (with-extensions (list guile-gcrypt)
  277. (with-imported-modules (source-module-closure '((guix config)
  278. (guix profiles)))
  279. #~(begin
  280. (use-modules (guix config)
  281. (guix profiles)
  282. (ice-9 textual-ports))
  283. (define %system-profile
  284. (string-append %state-directory "/profiles/system"))
  285. (define (read-file path)
  286. (call-with-input-file path
  287. (lambda (port)
  288. (get-string-all port))))
  289. (map (lambda (generation)
  290. (let* ((system-path (generation-file-name %system-profile
  291. generation))
  292. (boot-parameters-path (string-append system-path
  293. "/parameters"))
  294. (time (stat:mtime (lstat system-path))))
  295. (list generation
  296. system-path
  297. time
  298. (read-file boot-parameters-path))))
  299. (reverse (generation-numbers %system-profile)))))))
  300. (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
  301. (return
  302. (map (lambda (generation)
  303. (match generation
  304. ((generation system-path time serialized-params)
  305. (let* ((params (call-with-input-string serialized-params
  306. read-boot-parameters))
  307. (root (boot-parameters-root-device params))
  308. (label (boot-parameters-label params)))
  309. (boot-parameters
  310. (inherit params)
  311. (label
  312. (string-append label " (#"
  313. (number->string generation) ", "
  314. (let ((time (make-time time-utc 0 time)))
  315. (date->string (time-utc->date time)
  316. "~Y-~m-~d ~H:~M"))
  317. ")"))
  318. (kernel-arguments
  319. (append (bootable-kernel-arguments system-path root)
  320. (boot-parameters-kernel-arguments params))))))))
  321. generations))))
  322. (define-syntax-rule (with-roll-back should-roll-back? mbody ...)
  323. "Catch exceptions that arise when binding MBODY, a monadic expression in
  324. %STORE-MONAD, and collect their arguments in a &deploy-error condition, with
  325. the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
  326. (catch #t
  327. (lambda ()
  328. mbody ...)
  329. (lambda args
  330. (raise (condition (&deploy-error
  331. (should-roll-back should-roll-back?)
  332. (captured-args args)))))))
  333. (define (deploy-managed-host machine)
  334. "Internal implementation of 'deploy-machine' for MACHINE instances with an
  335. environment type of 'managed-host."
  336. (maybe-raise-unsupported-configuration-error machine)
  337. (when (machine-ssh-configuration-authorize?
  338. (machine-configuration machine))
  339. (unless (file-exists? %public-key-file)
  340. (raise (condition
  341. (&message
  342. (message (format #f (G_ "no signing key '~a'. \
  343. have you run 'guix archive --generate-key?'")
  344. %public-key-file))))))
  345. (remote-authorize-signing-key (call-with-input-file %public-key-file
  346. (lambda (port)
  347. (string->canonical-sexp
  348. (get-string-all port))))
  349. (machine-ssh-session machine)
  350. (machine-become-command machine)))
  351. (mlet %store-monad ((_ (check-deployment-sanity machine))
  352. (boot-parameters (machine-boot-parameters machine)))
  353. (let* ((os (machine-operating-system machine))
  354. (eval (cut machine-remote-eval machine <>))
  355. (menu-entries (map boot-parameters->menu-entry boot-parameters))
  356. (bootloader-configuration (operating-system-bootloader os))
  357. (bootcfg (operating-system-bootcfg os menu-entries)))
  358. (mbegin %store-monad
  359. (with-roll-back #f
  360. (switch-to-system eval os))
  361. (with-roll-back #t
  362. (mbegin %store-monad
  363. (upgrade-shepherd-services eval os)
  364. (install-bootloader eval bootloader-configuration bootcfg)))))))
  365. ;;;
  366. ;;; Roll-back.
  367. ;;;
  368. (define (roll-back-managed-host machine)
  369. "Internal implementation of 'roll-back-machine' for MACHINE instances with
  370. an environment type of 'managed-host."
  371. (define remote-exp
  372. (with-extensions (list guile-gcrypt)
  373. (with-imported-modules (source-module-closure '((guix config)
  374. (guix profiles)))
  375. #~(begin
  376. (use-modules (guix config)
  377. (guix profiles))
  378. (define %system-profile
  379. (string-append %state-directory "/profiles/system"))
  380. (define target-generation
  381. (relative-generation %system-profile -1))
  382. (if target-generation
  383. (switch-to-generation %system-profile target-generation)
  384. 'error)))))
  385. (define roll-back-failure
  386. (condition (&message (message (G_ "could not roll-back machine")))))
  387. (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
  388. (_ -> (if (< (length boot-parameters) 2)
  389. (raise roll-back-failure)))
  390. (entries -> (map boot-parameters->menu-entry
  391. (list (second boot-parameters))))
  392. (old-entries -> (map boot-parameters->menu-entry
  393. (drop boot-parameters 2)))
  394. (bootloader -> (operating-system-bootloader
  395. (machine-operating-system machine)))
  396. (bootcfg (lower-object
  397. ((bootloader-configuration-file-generator
  398. (bootloader-configuration-bootloader
  399. bootloader))
  400. bootloader entries
  401. #:old-entries old-entries)))
  402. (remote-result (machine-remote-eval machine remote-exp)))
  403. (when (eqv? 'error remote-result)
  404. (raise roll-back-failure))))
  405. ;;;
  406. ;;; Environment type.
  407. ;;;
  408. (define managed-host-environment-type
  409. (environment-type
  410. (machine-remote-eval managed-host-remote-eval)
  411. (deploy-machine deploy-managed-host)
  412. (roll-back-machine roll-back-managed-host)
  413. (name 'managed-host-environment-type)
  414. (description "Provisioning for machines that are accessible over SSH
  415. and have a known host-name. This entails little more than maintaining an SSH
  416. connection to the host.")))
  417. (define (maybe-raise-unsupported-configuration-error machine)
  418. "Raise an error if MACHINE's configuration is not an instance of
  419. <machine-ssh-configuration>."
  420. (let ((config (machine-configuration machine))
  421. (environment (environment-type-name (machine-environment machine))))
  422. (unless (and config (machine-ssh-configuration? config))
  423. (raise (condition
  424. (&message
  425. (message (format #f (G_ "unsupported machine configuration '~a'
  426. for environment of type '~a'")
  427. config
  428. environment))))))))