;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;; Copyright © 2020, 2021 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 (gnu machine ssh)
  #:use-module (gnu bootloader)
  #:use-module (gnu machine)
  #:autoload   (gnu packages gnupg) (guile-gcrypt)
  #:use-module (gnu system)
  #:use-module (gnu system</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=b802c104de0cde1cde85607983ae0c702dcc1354'>refs</a><a href='/guix/log/gnu/packages/mercury.scm'>log</a><a href='/guix/tree/gnu/packages/mercury.scm?id=b802c104de0cde1cde85607983ae0c702dcc1354'>tree</a><a class='active' href='/guix/commit/gnu/packages/mercury.scm?id=b802c104de0cde1cde85607983ae0c702dcc1354'>commit</a><a href='/guix/diff/gnu/packages/mercury.scm?id=b802c104de0cde1cde85607983ae0c702dcc1354'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/gnu/packages/mercury.scm'>
<input type='hidden' name='id' value='b802c104de0cde1cde85607983ae0c702dcc1354'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/commit/?id=b802c104de0cde1cde85607983ae0c702dcc1354'>root</a>/<a href='/guix/commit/gnu?id=b802c104de0cde1cde85607983ae0c702dcc1354'>gnu</a>/<a href='/guix/commit/gnu/packages?id=b802c104de0cde1cde85607983ae0c702dcc1354'>packages</a>/<a href='/guix/commit/gnu/packages/mercury.scm?id=b802c104de0cde1cde85607983ae0c702dcc1354'>mercury.scm</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='b802c104de0cde1cde85607983ae0c702dcc1354'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><table summary='commit info' class='commit-info'>
<tr><th>author</th><td>Efraim Flashner &lt;efraim@flashner.co.il&gt;</td><td class='right'>2023-10-11 14:10:18 +0300</td></tr>
<tr><th>committer</th><td>Efraim Flashner &lt;efraim@flashner.co.il&gt;</td><td class='right'>2023-10-12 17:00:50 +0300</td></tr>
<tr><th>commit</th><td colspan='2' class='oid'><a href='/guix/commit/gnu/packages/mercury.scm?id=b802c104de0cde1cde85607983ae0c702dcc1354'>b802c104de0cde1cde85607983ae0c702dcc1354</a> (<a href='/guix/patch/gnu/packages/mercury.scm?id=b802c104de0cde1cde85607983ae0c702dcc1354'>patch</a>)</td></tr>
<tr><th>tree</th><td colspan='2' class='oid'><a href='/guix/tree/?id=b802c104de0cde1cde85607983ae0c702dcc1354'>bb0ff5b3b91b8a669377cfac096c452f44efb7fd</a> /<a href='/guix/tree/gnu/packages/mercury.scm?id=b802c104de0cde1cde85607983ae0c702dcc1354'>gnu/packages/mercury.scm</a></td></tr>
<tr><th>parent</th><td colspan='2' class='oid'><a href='/guix/commit/gnu/packages/mercury.scm?id=b418fdb191808783fd60e9b858567fd642e32634'>b418fdb191808783fd60e9b858567fd642e32634</a> (<a href='/guix/diff/gnu/packages/mercury.scm?id=b802c104de0cde1cde85607983ae0c702dcc1354&amp;id2=b418fdb191808783fd60e9b858567fd642e32634'>diff</a>)</td></tr><tr><th>download</th><td colspan='2' class='oid'><a href='/guix/snapshot/guix-b802c104de0cde1cde85607983ae0c702dcc1354.tar.gz'>guix-b802c104de0cde1cde85607983ae0c702dcc1354.tar.gz</a><br/><a href='/guix/snapshot/guix-b802c104de0cde1cde85607983ae0c702dcc1354.zip'>guix-b802c104de0cde1cde85607983ae0c702dcc1354.zip</a><br/></td></tr></table>
<div class='commit-subject'>gnu: stfl: Fix cross-compiling.</div><div class='commit-msg'>* gnu/packages/ncurses.scm (stfl)[native-inputs]: Add ncurses.
</div><div class='diffstat-header'><a href='/guix/diff/?id=b802c104de0cde1cde85607983ae0c702dcc1354'>Diffstat</a> (limited to 'gnu/packages/mercury.scm')</div><table summary='diffstat' class='diffstat'></table><div class='diffstat-summary'>0 files changed, 0 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
one.  (This is pretty much a monad.)
(define-record-type <remote-assertion>
  (remote-assertion exp proc)
  remote-assertion?
  (exp   remote-assertion-expression)
  (proc  remote-assertion-procedure))

(define-syntax-rule (remote-let ((var exp)) body ...)
  "Return a <remote-assertion> that binds VAR to the result of evaluating EXP,
a gexp, remotely, and evaluate BODY in that context."
  (remote-assertion exp (lambda (var) body ...)))

(define (machine-check-file-system-availability machine)
  "Return a list of <remote-assertion> that raise a '&message' error condition
if any of the file-systems specified in MACHINE's 'system' declaration do not
exist on the machine."
  (define file-systems
    (filter (lambda (fs)
              (and (file-system-mount? fs)
                   (not (member (file-system-type fs)
                                %pseudo-file-system-types))
                   ;; Don't try to validate network file systems.
                   (not (string-prefix? "nfs" (file-system-type fs)))
                   (not (memq 'bind-mount (file-system-flags fs)))))
            (operating-system-file-systems (machine-operating-system machine))))

  (define (check-literal-file-system fs)
    (remote-let ((errno #~(catch 'system-error
                            (lambda ()
                              (stat #$(file-system-device fs))
                              #t)
                            (lambda args
                              (system-error-errno args)))))
      (when (number? errno)
        (raise (formatted-message (G_ "device '~a' not found: ~a")
                                  (file-system-device fs)
                                  (strerror errno))))))

  (define (check-labeled-file-system fs)
    (define remote-exp
      (with-imported-modules (source-module-closure
                              '((gnu build file-systems)))
        #~(begin
            (use-modules (gnu build file-systems))
            (find-partition-by-label #$(file-system-label->string
                                        (file-system-device fs))))))

    (remote-let ((result remote-exp))
      (unless result
        (raise (formatted-message (G_ "no file system with label '~a'")
                                  (file-system-label->string
                                   (file-system-device fs)))))))

  (define (check-uuid-file-system fs)
    (define remote-exp
      (with-imported-modules (source-module-closure
                              '((gnu build file-systems)
                                (gnu system uuid)))
        #~(begin
            (use-modules (gnu build file-systems)
                         (gnu system uuid))

            (let ((uuid (uuid #$(uuid->string (file-system-device fs))
                              '#$(uuid-type (file-system-device fs)))))
              (find-partition-by-uuid uuid)))))

    (remote-let ((result remote-exp))
      (unless result
        (raise (formatted-message (G_ "no file system with UUID '~a'")
                                  (uuid->string (file-system-device fs)))))))

  (append (map check-literal-file-system
               (filter (lambda (fs)
                         (string? (file-system-device fs)))
                       file-systems))
          (map check-labeled-file-system
               (filter (lambda (fs)
                         (file-system-label? (file-system-device fs)))
                       file-systems))
          (map check-uuid-file-system
               (filter (lambda (fs)
                         (uuid? (file-system-device fs)))
                       file-systems))))

(define (machine-check-initrd-modules machine)
  "Return a list of <remote-assertion> that raise a '&message' error condition
if any of the modules needed by 'needed-for-boot' file systems in MACHINE are
not available in the initrd."
  (define file-systems
    (filter file-system-needed-for-boot?
            (operating-system-file-systems (machine-operating-system machine))))

  (define (missing-modules fs)
    (define remote-exp
      (let ((device (file-system-device fs)))
        (with-imported-modules (source-module-closure
                                '((gnu build file-systems)
                                  (gnu build linux-modules)
                                  (gnu system uuid)))
          #~(begin
              (use-modules (gnu build file-systems)
                           (gnu build linux-modules)
                           (gnu system uuid))

              (define dev
                #$(cond ((string? device) device)
                        ((uuid? device) #~(find-partition-by-uuid
                                           (string->uuid
                                            #$(uuid->string device))))
                        ((file-system-label? device)
                         #~(find-partition-by-label
                            #$(file-system-label->string device)))))

              (missing-modules dev '#$(operating-system-initrd-modules
                                       (machine-operating-system machine)))))))

    (remote-let ((missing remote-exp))
      (unless (null? missing)
        (raise (formatted-message (G_ "missing modules for ~a:~{ ~a~}~%")
                                  (file-system-device fs)
                                  missing)))))

  (map missing-modules file-systems))

(define* (machine-check-forward-update machine)
  "Check whether we are making a forward update for MACHINE.  Depending on its
'allow-upgrades?' field, raise an error or display a warning if we are
potentially downgrading it."
  (define config
    (machine-configuration machine))

  (define validate-reconfigure
    (if (machine-ssh-configuration-allow-downgrades? config)
        warn-about-backward-reconfigure
        ensure-forward-reconfigure))

  (remote-let ((provenance #~(call-with-input-file
                                 "/run/current-system/provenance"
                               read)))
    (define channels
      (sexp->system-provenance provenance))

    (check-forward-update validate-reconfigure
                          #:current-channels channels)))

(define (machine-check-building-for-appropriate-system machine)
  "Raise a '&message' error condition if MACHINE is configured to be built
locally and the 'system' field does not match the '%current-system' reported
by MACHINE."
  (let ((config (machine-configuration machine))
        (system (remote-system (machine-ssh-session machine))))
    (when (and (machine-ssh-configuration-build-locally? config)
               (not (string= system (machine-ssh-configuration-system config))))
      (raise (formatted-message (G_ "incorrect target system\
 ('~a' was given, while the system reports that it is '~a')~%")
                                (machine-ssh-configuration-system config)
                                system)))))

(define (check-deployment-sanity machine)
  "Raise a '&message' error condition if it is clear that deploying MACHINE's
'system' declaration would fail."
  (define assertions
    (append (machine-check-file-system-availability machine)
            (machine-check-initrd-modules machine)
            (list (machine-check-forward-update machine))))

  (define aggregate-exp
    ;; Gather all the expressions so that a single round-trip is enough to
    ;; evaluate all the ASSERTIONS remotely.
    #~(map (lambda (file)
             (false-if-exception (primitive-load file)))
           '#$(map (lambda (assertion)
                     (scheme-file "remote-assertion.scm"
                                  (remote-assertion-expression assertion)))
                   assertions)))

  ;; First check MACHINE's system type--an incorrect value for 'system' would
  ;; cause subsequent invocations of 'remote-eval' to fail.
  (machine-check-building-for-appropriate-system machine)

  (mlet %store-monad ((values (machine-remote-eval machine aggregate-exp)))
    (for-each (lambda (proc value)
                (proc value))
              (map remote-assertion-procedure assertions)
              values)
    (return #t)))


;;;
;;; System deployment.
;;;

(define not-config?
  ;; Select (guix …) and (gnu …) modules, except (guix config).
  (match-lambda
    (('guix 'config) #f)
    (('guix _ ...) #t)
    (('gnu _ ...) #t)
    (_ #f)))

(define (machine-boot-parameters machine)
  "Monadic procedure returning a list of 'boot-parameters' for the generations
of MACHINE's system profile, ordered from most recent to oldest."
  (define bootable-kernel-arguments
    (@@ (gnu system) bootable-kernel-arguments))

  (define remote-exp
    (with-extensions (list guile-gcrypt)
      (with-imported-modules `(((guix config) => ,(make-config.scm))
                               ,@(source-module-closure
                                  '((guix profiles))
                                  #:select? not-config?))
        #~(begin
            (use-modules (guix config)
                         (guix profiles)
                         (ice-9 textual-ports))

            (define %system-profile
              (string-append %state-directory "/profiles/system"))

            (define (read-file path)
              (call-with-input-file path
                (lambda (port)
                  (get-string-all port))))

            (map (lambda (generation)
                   (let* ((system-path (generation-file-name %system-profile
                                                             generation))
                          (boot-parameters-path (string-append system-path
                                                               "/parameters"))
                          (time (stat:mtime (lstat system-path))))
                     (list generation
                           system-path
                           time
                           (read-file boot-parameters-path))))
                 (reverse (generation-numbers %system-profile)))))))

  (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
    (return
     (map (lambda (generation)
            (match generation
              ((generation system-path time serialized-params)
               (let* ((params (call-with-input-string serialized-params
                                read-boot-parameters))
                      (root (boot-parameters-root-device params))
                      (label (boot-parameters-label params)))
                 (boot-parameters
                  (inherit params)
                  (label
                   (string-append label " (#"
                                  (number->string generation) ", "
                                  (let ((time (make-time time-utc 0 time)))
                                    (date->string (time-utc->date time)
                                                  "~Y-~m-~d ~H:~M"))
                                  ")"))
                  (kernel-arguments
                   (append (bootable-kernel-arguments system-path root)
                           (boot-parameters-kernel-arguments params))))))))
          generations))))

(define-syntax-rule (with-roll-back should-roll-back? mbody ...)
  "Catch exceptions that arise when binding MBODY, a monadic expression in
%STORE-MONAD, and collect their arguments in a &deploy-error condition, with
the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
  (catch #t
    (lambda ()
      mbody ...)
    (lambda args
      (raise (condition (&deploy-error
                         (should-roll-back should-roll-back?)
                         (captured-args args)))))))

(define (deploy-managed-host machine)
  "Internal implementation of 'deploy-machine' for MACHINE instances with an
environment type of 'managed-host."
  (maybe-raise-unsupported-configuration-error machine)
  (when (machine-ssh-configuration-authorize?
         (machine-configuration machine))
    (unless (file-exists? %public-key-file)
      (raise (formatted-message (G_ "no signing key '~a'. \
have you run 'guix archive --generate-key?'")
                                %public-key-file)))
    (remote-authorize-signing-key (call-with-input-file %public-key-file
                                    (lambda (port)
                                      (string->canonical-sexp
                                       (get-string-all port))))
                                  (machine-ssh-session machine)
                                  (machine-become-command machine)))
  (mlet %store-monad ((_ (check-deployment-sanity machine))
                      (boot-parameters (machine-boot-parameters machine)))
    (let* ((os (machine-operating-system machine))
           (host (machine-ssh-configuration-host-name
                  (machine-configuration machine)))
           (eval (cut machine-remote-eval machine <>))
           (menu-entries (map boot-parameters->menu-entry boot-parameters))
           (bootloader-configuration (operating-system-bootloader os))
           (bootcfg (operating-system-bootcfg os menu-entries)))
      (define-syntax-rule (eval/error-handling condition handler ...)
        ;; Return a wrapper around EVAL such that HANDLER is evaluated if an
        ;; exception is raised.
        (lambda (exp)
          (lambda (store)
            (guard (condition ((inferior-exception? condition)
                               (values (begin handler ...) store)))
              (values (run-with-store store (eval exp))
                      store)))))

      (mbegin %store-monad
        (with-roll-back #f
          (switch-to-system (eval/error-handling c
                              (raise (formatted-message
                                      (G_ "\
failed to switch systems while deploying '~a':~%~{~s ~}")
                                      host
                                      (inferior-exception-arguments c))))
                            os))
        (with-roll-back #t
          (mbegin %store-monad
            (upgrade-shepherd-services (eval/error-handling c
                                         (warning (G_ "\
an error occurred while upgrading services on '~a':~%~{~s ~}~%")
                                                  host
                                                  (inferior-exception-arguments
                                                   c)))
                                       os)
            (install-bootloader (eval/error-handling c
                                  (raise (formatted-message
                                          (G_ "\
failed to install bootloader on '~a':~%~{~s ~}~%")
                                          host
                                          (inferior-exception-arguments c))))
                                bootloader-configuration bootcfg)))))))


;;;
;;; Roll-back.
;;;

(define (roll-back-managed-host machine)
  "Internal implementation of 'roll-back-machine' for MACHINE instances with
an environment type of 'managed-host."
  (define remote-exp
    (with-extensions (list guile-gcrypt)
      (with-imported-modules (source-module-closure '((guix config)
                                                      (guix profiles)))
        #~(begin
            (use-modules (guix config)
                         (guix profiles))

            (define %system-profile
              (string-append %state-directory "/profiles/system"))

            (define target-generation
              (relative-generation %system-profile -1))

            (if target-generation
                (switch-to-generation %system-profile target-generation)
                'error)))))

  (define roll-back-failure
    (condition (&message (message (G_ "could not roll-back machine")))))

  (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
                       (_ -> (if (< (length boot-parameters) 2)
                                 (raise roll-back-failure)))
                       (entries -> (map boot-parameters->menu-entry
                                        (list (second boot-parameters))))
                       (locale -> (boot-parameters-locale
                                   (second boot-parameters)))
                       (crypto-dev -> (boot-parameters-store-crypto-devices
                                       (second boot-parameters)))
                       (store-dir -> (boot-parameters-store-directory-prefix
                                      (second boot-parameters)))
                       (old-entries -> (map boot-parameters->menu-entry
                                            (drop boot-parameters 2)))
                       (bootloader -> (operating-system-bootloader
                                       (machine-operating-system machine)))
                       (bootcfg (lower-object
                                 ((bootloader-configuration-file-generator
                                   (bootloader-configuration-bootloader
                                    bootloader))
                                  bootloader entries
                                  #:locale locale
                                  #:store-crypto-devices crypto-dev
                                  #:store-directory-prefix store-dir
                                  #:old-entries old-entries)))
                       (remote-result (machine-remote-eval machine remote-exp)))
    (when (eqv? 'error remote-result)
      (raise roll-back-failure))))


;;;
;;; Environment type.
;;;

(define managed-host-environment-type
  (environment-type
   (machine-remote-eval managed-host-remote-eval)
   (deploy-machine      deploy-managed-host)
   (roll-back-machine   roll-back-managed-host)
   (name                'managed-host-environment-type)
   (description         "Provisioning for machines that are accessible over SSH
and have a known host-name. This entails little more than maintaining an SSH
connection to the host.")))

(define (maybe-raise-unsupported-configuration-error machine)
  "Raise an error if MACHINE's configuration is not an instance of
<machine-ssh-configuration>."
  (let ((config (machine-configuration machine))
        (environment (environment-type-name (machine-environment machine))))
    (unless (and config (machine-ssh-configuration? config))
      (raise (formatted-message (G_ "unsupported machine configuration '~a'
for environment of type '~a'")
                                config
                                environment)))))

;; Local Variables:
;; eval: (put 'remote-let 'scheme-indent-function 1)
;; eval: (put 'with-roll-back 'scheme-indent-function 1)
;; eval: (put 'eval/error-handling 'scheme-indent-function 1)
;; End: