;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.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 services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix monads)
  #:use-module (guix records)
  #:use-module (guix ssh)
  #:use-module (guix store)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-19)
  #:export (machine-ssh-configuration
            machine-ssh-configuration?
            machine-ssh-configuration

            machine-ssh-configuration-host-name
            machine-ssh-configuration-port
            machine-ssh-configuration-user
            machine-ssh-configuration-session))

;;; Commentary:
;;;
;;; This module implements remote evaluation and system deployment for
;;; machines that are accessable over SSH and have a known host-name. In the
;;; sense of the broader "machine" interface, we describe the environment for
;;; such machines as 'managed-host.
;;;
;;; Code:


;;;
;;; SSH client parameter configuration.
;;;

(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
  make-machine-ssh-configuration
  machine-ssh-configuration?
  this-machine-ssh-configuration
  (host-name machine-ssh-configuration-host-name) ; string
  (port      machine-ssh-configuration-port       ; integer
             (default 22))
  (user      machine-ssh-configuration-user       ; string
             (default "root"))
  (identity  machine-ssh-configuration-identity   ; path to a private key
             (default #f))
  (session   machine-ssh-configuration-session    ; session
             (default #f)))

(define (machine-ssh-session machine)
  "Return the SSH session that was given in MACHINE's configuration, or create
one from the configuration's parameters if one was not provided."
  (let ((config (machine-configuration machine)))
    (if (machine-ssh-configuration? config)
        (or (machine-ssh-configuration-session config)
            (let ((host-name (machine-ssh-configuration-host-name config))
                  (user (machine-ssh-configuration-user config))
                  (port (machine-ssh-configuration-port config))
                  (identity (machine-ssh-configuration-identity config)))
              (open-ssh-session host-name
                                #:user user
                                #:port port
                                #:identity identity)))
        (error "unsupported configuration type"))))


;;;
;;; Remote evaluation.
;;;

(define (remote-eval machine exp)
  "Internal implementation of 'remote-eval' for MACHINE instances with an
environment type of 'managed-host."
  (unless (machine-configuration machine)
    (error (format #f (G_ "no configuration specified for machine of environment '~a'")
                   (symbol->string (machine-environment machine)))))
  ((@ (guix remote) remote-eval) exp (machine-ssh-session machine)))

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

(define (switch-to-system machine)
  "Monadic procedure creating a new generation on MACHINE and execute the
activation script for the new system configuration."
  (define (remote-exp drv script)
    (with-extensions (list guile-gcrypt)
      (with-imported-modules (source-module-closure '((guix config)
                                                      (guix profiles)
                                                      (guix utils)))
        #~(begin
            (use-modules (guix config)
                         (guix profiles)
                         (guix utils))

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

            (let* ((system #$(derivation->output-path drv))
                   (number (1+ (generation-number %system-profile)))
                   (generation (generation-file-name %system-profile number))
                   (old-env (environ))
                   (old-path %load-path)
                   (old-cpath %load-compiled-path))
              (switch-symlinks generation system)
              (switch-symlinks %system-profile generation)
              ;; Guard against the activation script modifying $PATH.
              (dynamic-wind
                (const #t)
                (lambda ()
                  (setenv "GUIX_NEW_SYSTEM" system)
                  ;; Guard against the activation script modifying '%load-path'.
                  (dynamic-wind
                    (const #t)
                    (lambda ()
                      ;; The activation script may write to stdout, which
                      ;; confuses 'remote-eval' when it attempts to read a
                      ;; result from the remote REPL. We work around this by
                      ;; forcing the output to a string.
                      (with-output-to-string
                        (lambda ()
                          (primitive-load #$script))))
                    (lambda ()
                      (set! %load-path old-path)
                      (set! %load-compiled-path old-cpath))))
                (lambda ()
                  (environ old-env))))))))

  (let* ((os (machine-system machine))
         (script (operating-system-activation-script os)))
    (mlet* %store-monad ((drv (operating-system-derivation os)))
      (remote-eval machine (remote-exp drv script)))))

(define (upgrade-shepherd-services machine)
  "Monadic procedure unloading and starting services on the remote as needed
to realize the MACHINE's system configuration."
  (define target-services
    ;; Monadic expression evaluating to a list of (name output-path) pairs for
    ;; all of MACHINE's services.
    (mapm %store-monad
          (lambda (service)
            (mlet %store-monad ((file ((compose lower-object
                                                shepherd-service-file)
                                       service)))
              (return (list (shepherd-service-canonical-name service)
                            (derivation->output-path file)))))
          (service-value
           (fold-services (operating-system-services (machine-system machine))
                          #:target-type shepherd-root-service-type))))

  (define (remote-exp target-services)
    (with-imported-modules '((gnu services herd))
      #~(begin
          (use-modules (gnu services herd)
                       (srfi srfi-1))

          (define running
            (filter live-service-running (current-services)))

          (define (essential? service)
            ;; Return #t if SERVICE is essential and should not be unloaded
            ;; under any circumstance.
            (memq (first (live-service-provision service))
                  '(root shepherd)))

          (define (obsolete? service)
            ;; Return #t if SERVICE can be safely unloaded.
            (and (not (essential? service))
                 (every (lambda (requirements)
                          (not (memq (first (live-service-provision service))
                                     requirements)))
                        (map live-service-requirement running))))

          (define to-unload
            (filter obsolete?
                    (remove (lambda (service)
                              (memq (first (live-service-provision service))
                                    (map first '#$target-services)))
                            running)))

          (define to-start
            (remove (lambda (service-pair)
                      (memq (first service-pair)
                            (map (compose first live-service-provision)
                                 running)))
                    '#$target-services))

          ;; Unload obsolete services.
          (for-each (lambda (service)
                      (false-if-exception
                       (unload-service service)))
                    to-unload)

          ;; Load the service files for any new services and start them.
          (load-services/safe (map second to-start))
          (for-each start-service (map first to-start))

          #t)))

  (mlet %store-monad ((target-services target-services))
    (remote-eval machine (remote-exp target-services))))

(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 (source-module-closure '((guix config)
                                                      (guix profiles)))
        #~(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 (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 (install-bootloader machine)
  "Create a bootloader entry for the new system generation on MACHINE, and
configure the bootloader to boot that generation by default."
  (define bootloader-installer-script
    (@@ (guix scripts system) bootloader-installer-script))

  (define (remote-exp installer bootcfg bootcfg-file)
    (with-extensions (list guile-gcrypt)
      (with-imported-modules (source-module-closure '((gnu build install)
                                                      (guix store)
                                                      (guix utils)))
        #~(begin
            (use-modules (gnu build install)
                         (guix store)
                         (guix utils))
            (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg"))
                   (temp-gc-root (string-append gc-root ".new"))
                   (old-path %load-path)
                   (old-cpath %load-compiled-path))
              (switch-symlinks temp-gc-root gc-root)

              (unless (false-if-exception
                       (begin
                         (install-boot-config #$bootcfg #$bootcfg-file "/")
                         ;; Guard against the activation script modifying
                         ;; '%load-path'.
                         (dynamic-wind
                           (const #t)
                           (lambda ()
                             ;; The installation script may write to stdout,
                             ;; which confuses 'remote-eval' when it attempts to
                             ;; read a result from the remote REPL. We work
                             ;; around this by forcing the output to a string.
                             (with-output-to-string
                               (lambda ()
                                 (primitive-load #$installer))))
                           (lambda ()
                             (set! %load-path old-path)
                             (set! %load-compiled-path old-cpath)))))
                (delete-file temp-gc-root)
                (error "failed to install bootloader"))

              (rename-file temp-gc-root gc-root)
              #t)))))

  (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
    (let* ((os (machine-system machine))
           (bootloader ((compose bootloader-configuration-bootloader
                                 operating-system-bootloader)
                        os))
           (bootloader-target (bootloader-configuration-target
                               (operating-system-bootloader os)))
           (installer (bootloader-installer-script
                       (bootloader-installer bootloader)
                       (bootloader-package bootloader)
                       bootloader-target
                       "/"))
           (menu-entries (map boot-parameters->menu-entry boot-parameters))
           (bootcfg (operating-system-bootcfg os menu-entries))
           (bootcfg-file (bootloader-configuration-file bootloader)))
      (remote-eval machine (remote-exp installer bootcfg bootcfg-file)))))

(define (deploy-machine machine)
  "Internal implementation of 'deploy-machine' for MACHINE instances with an
environment type of 'managed-host."
  (unless (machine-configuration machine)
    (error (format #f (G_ "no configuration specified for machine of environment '~a'")
                   (symbol->string (machine-environment machine)))))
  (mbegin %store-monad
    (switch-to-system machine)
    (upgrade-shepherd-services machine)
    (install-bootloader machine)))