code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@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 ci)
  #:use-module (guix channels)
  #:use-module (guix config)
  #:use-module (guix describe)
  #:use-module (guix store)
  #:use-module (guix grafts)
  #:use-module (guix profiles)
  #:use-module (guix packages)
  #:use-module (guix channels)
  #:use-module (guix config)
  #:use-module (guix derivations)
  #:use-module (guix build-system)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix ui)
  #:use-module ((guix licenses)
                #:select (gpl3+ license? license-name))
  #:use-module ((guix utils) #:select (%current-system))
  #:use-module ((guix scripts system) #:select (read-operating-system))
  #:use-module ((guix scripts pack)
                #:select (lookup-compressor self-contained-tarball))
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader u-boot)
  #:use-module (gnu image)
  #:use-module (gnu packages)
  #:use-module (gnu packages gcc)
  #:use-module (gnu packages base)
  #:use-module (gnu packages gawk)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages gettext)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages multiprecision)
  #:use-module (gnu packages make-bootstrap)
  #:use-module (gnu packages package-management)
  #:use-module (gnu system)
  #:use-module (gnu system image)
  #:use-module (gnu system vm)
  #:use-module (gnu system install)
  #:use-module (gnu system images hurd)
  #:use-module (gnu system images novena)
  #:use-module (gnu system images pine64)
  #:use-module (gnu system images pinebook-pro)
  #:use-module (gnu tests)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (derivation->job
            image->job

            %bootstrap-packages
            %core-packages
            %cross-targets
            channel-source->package

            arguments->systems
            cuirass-jobs))

;;; Commentary:
;;;
;;; This file defines build jobs for Cuirass.
;;;
;;; Code:

(define* (derivation->job name drv
                          #:key
                          (max-silent-time 3600)
                          (timeout 3600))
  "Return a Cuirass job called NAME and describing DRV.

MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
building the derivation."
  `((#:job-name . ,name)
    (#:derivation . ,(derivation-file-name drv))
    (#:inputs . ,(map (compose derivation-file-name
                               derivation-input-derivation)
                      (derivation-inputs drv)))
    (#:outputs . ,(filter-map
                   (lambda (res)
                     (match res
                       ((name . path)
                        `(,name . ,path))))
                   (derivation->output-paths drv)))
    (#:nix-name . ,(derivation-name drv))
    (#:system . ,(derivation-system drv))
    (#:max-silent-time . ,max-silent-time)
    (#:timeout . ,timeout)))

(define* (package-job store job-name package system
                      #:key cross? target)
  "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
  (let ((job-name (string-append job-name "." system)))
    (parameterize ((%graft? #f))
      (let* ((drv (if cross?
                      (package-cross-derivation store package target system
                                                #:graft? #f)
                      (package-derivation store package system
                                          #:graft? #f)))
             (max-silent-time (or (assoc-ref (package-properties package)
                                             'max-silent-time)
                                  3600))
             (timeout (or (assoc-ref (package-properties package)
                                     'timeout)
                          72000)))
        (derivation->job job-name drv
                         #:max-silent-time max-silent-time
                         #:timeout timeout)))))

(define (package-cross-job store job-name package target system)
  "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
SYSTEM."
  (let ((name (string-append target "." job-name "." system)))
    (package-job store name package system
                 #:cross? #t
                 #:target target)))

(define %core-packages
  ;; Note: Don't put the '-final' package variants because (1) that's
  ;; implicit, and (2) they cannot be cross-built (due to the explicit input
  ;; chain.)
  (list gcc-7 gcc-8 gcc-9 gcc-10 glibc binutils
        gmp mpfr mpc coreutils findutils diffutils patch sed grep
        gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
        %bootstrap-binaries-tarball
        %binutils-bootstrap-tarball
        (%glibc-bootstrap-tarball)
        %gcc-bootstrap-tarball
        %guile-bootstrap-tarball
        %bootstrap-tarballs))

(define %bootstrap-packages
  ;; Return the list of bootstrap packages from the commencement module.
  (filter package?
          (module-map
           (lambda (sym var)
             (variable-ref var))
           (resolve-module '(gnu packages commencement)))))

(define (packages-to-cross-build target)
  "Return the list of packages to cross-build for TARGET."
  ;; Don't cross-build the bootstrap tarballs for MinGW.
  (if (string-contains target "mingw")
      (drop-right %core-packages 6)
      %core-packages))

(define %cross-targets
  '("mips64el-linux-gnu"
    "arm-linux-gnueabihf"
    "aarch64-linux-gnu"
    "powerpc-linux-gnu"
    "powerpc64le-linux-gnu"
    "riscv64-linux-gnu"
    "i586-pc-gnu"                                 ;aka. GNU/Hurd
    "i686-w64-mingw32"
    "x86_64-w64-mingw32"))

(define (cross-jobs store system)
  "Return a list of cross-compilation jobs for SYSTEM."
  (define (from-32-to-64? target)
    ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.  This hack
    ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
    ;; mips64el-linux-gnuabi64.
    (and (or (string-prefix? "i686-" system)
             (string-prefix? "i586-" system)
             (string-prefix? "armhf-" system))
         (string-contains target "64")))    ;x86_64, mips64el, aarch64, etc.

  (define (same? target)
    ;; Return true if SYSTEM and TARGET are the same thing.  This is so we
    ;; don't try to cross-compile to 'mips64el-linux-gnu' from
    ;; 'mips64el-linux'.
    (or (string-contains target system)
        (and (string-prefix? "armhf" system)    ;armhf-linux
             (string-prefix? "arm" target))))   ;arm-linux-gnueabihf

  (define (pointless? target)
    ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
    (match system
      ((or "x86_64-linux" "i686-linux")
       (if (string-contains target "mingw")
           (not (string=? "x86_64-linux" system))
           #f))
      (_
       ;; Don't try to cross-compile from non-Intel platforms: this isn't
       ;; very useful and these are often brittle configurations.
       #t)))

  (define (either proc1 proc2 proc3)
    (lambda (x)
      (or (proc1 x) (proc2 x) (proc3 x))))

  (append-map (lambda (target)
                (map (lambda (package)
                       (package-cross-job store (job-name package)
                                          package target system))
                     (packages-to-cross-build target)))
              (remove (either from-32-to-64? same? pointless?)
                      %cross-targets)))

(define* (guix-jobs store systems #:key source commit)
  "Return a list of jobs for Guix itself."
  (define build
    (primitive-load (string-append source "/build-aux/build-self.scm")))

  (map
   (lambda (system)
     (let ((name (string->symbol
                  (string-append "guix." system)))
           (drv (run-with-store store
                  (build source #:version commit #:system system
                         #:pull-version 1
                         #:guile-version "2.2"))))
       (derivation->job name drv)))
   systems))

;; Architectures that are able to build or cross-build Guix System images.
;; This does not mean that other architectures are not supported, only that
;; they are often not fast enough to support Guix System images building.
(define %guix-system-supported-systems
  '("x86_64-linux" "i686-linux"))

(define %guix-system-images
  (list hurd-barebones-qcow2-image
        pine64-barebones-raw-image
        pinebook-pro-barebones-raw-image
        novena-barebones-raw-image))

(define (hours hours)
  (* 3600 hours))

(define* (image->job store image
                     #:key name system)
  "Return the job for IMAGE on SYSTEM.  If NAME is passed, use it as job name,
otherwise use the IMAGE name."
  (let* ((image-name (or name
                         (symbol->string (image-name image))))
         (name (string-append image-name "." system))
         (drv (run-with-store store
                (mbegin %store-monad
                  (set-guile-for-build (default-guile))
                  (lower-object (system-image image))))))
    (parameterize ((%graft? #f))
      (derivation->job name drv))))

(define (image-jobs store system)
  "Return a list of jobs that build images for SYSTEM."
  (define MiB
    (expt 2 20))

  (if (member system %guix-system-supported-systems)
      `(,(image->job store
                     (image
                      (inherit efi-disk-image)
                      (operating-system installation-os))
                     #:name "usb-image"
                     #:system system)
        ,(image->job
          store
          (image
           (inherit (image-with-label
                     iso9660-image
                     (string-append "GUIX_" system "_"
                                    (if (> (string-length %guix-version) 7)
                                        (substring %guix-version 0 7)
                                        %guix-version))))
           (operating-system installation-os))
          #:name "iso9660-image"
          #:system system)
        ;; Only cross-compile Guix System images from x86_64-linux for now.
        ,@(if (string=? system "x86_64-linux")
              (map (cut image->job store <>
                        #:system system)
                   %guix-system-images)
              '()))
      '()))

(define channel-build-system
  ;; Build system used to "convert" a channel instance to a package.
  (let* ((build (lambda* (store name inputs
                                #:key source commit system
                                #:allow-other-keys)
                  (run-with-store store
                    ;; SOURCE can be a lowerable object such as <local-file>
                    ;; or a file name.  Adjust accordingly.
                    (mlet* %store-monad ((source (if (string? source)
                                                     (return source)
                                                     (lower-object source)))
                                         (instance
                                          -> (checkout->channel-instance
                                              source #:commit commit)))
                      (channel-instances->derivation (list instance)))
                    #:system system)))
         (lower (lambda* (name #:key system source commit
                               #:allow-other-keys)
                  (bag
                    (name name)
                    (system system)
                    (build build)
                    (arguments `(#:source ,source
                                 #:commit ,commit))))))
    (build-system (name 'channel)
                  (description "Turn a channel instance into a package.")
                  (lower lower))))

(define* (channel-source->package source #:key commit)
  "Return a package for the given channel SOURCE, a lowerable object."
  (package
    (inherit guix)
    (version (string-append (package-version guix) "+"))
    (build-system channel-build-system)
    (arguments `(#:source ,source
                 #:commit ,commit))
    (inputs '())
    (native-inputs '())
    (propagated-inputs '())))

(define* (system-test-jobs store system
                           #:key source commit)
  "Return a list of jobs for the system tests."
  (define (->job test)
    (let ((name (string-append "test." (system-test-name test)
                               "." system))
          (drv (run-with-store store
                 (mbegin %store-monad
                   (set-current-system system)
                   (set-grafting #f)
                   (set-guile-for-build (default-guile))
                   (system-test-value test)))))

      (derivation->job name drv)))

  (if (member system %guix-system-supported-systems)
      ;; Override the value of 'current-guix' used by system tests.  Using a
      ;; channel instance makes tests that rely on 'current-guix' less
      ;; expensive.  It also makes sure we get a valid Guix package when this
      ;; code is not running from a checkout.
      (parameterize ((current-guix-package
                      (channel-source->package source #:commit commit)))
        (map ->job (all-system-tests)))
      '()))

(define (tarball-jobs store system)
  "Return jobs to build the self-contained Guix binary tarball."
  (define (->job name drv)
    (let ((name (string-append name "." system)))
      (parameterize ((%graft? #f))
        (derivation->job name drv))))

  ;; XXX: Add a job for the stable Guix?
  (list
   (->job "binary-tarball"
          (run-with-store store
            (mbegin %store-monad
              (set-guile-for-build (default-guile))
              (>>= (profile-derivation (packages->manifest (list guix)))
                   (lambda (profile)
                     (self-contained-tarball "guix-binary" profile
                                             #:profile-name "current-guix"
                                             #:localstatedir? #t
                                             #:compressor
                                             (lookup-compressor "xz")))))
            #:system system))))

(define job-name
  ;; Return the name of a package's job.
  package-name)

(define package->job
  (let ((base-packages
         (delete-duplicates
          (append-map (match-lambda
                        ((_ package _ ...)
                         (match (package-transitive-inputs package)
                           (((_ inputs _ ...) ...)
                            inputs))))
                      (%final-inputs)))))
    (lambda (store package system)
      "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
valid."
      (cond ((member package base-packages)
             (package-job store (string-append "base." (job-name package))
                          package system))
            ((supported-package? package system)
             (let ((drv (package-derivation store package system
                                            #:graft? #f)))
               (and (substitutable-derivation? drv)
                    (package-job store (job-name package)
                                 package system))))
            (else
             #f)))))

(define (all-packages)
  "Return the list of packages to build."
  (define (adjust package result)
    (cond ((package-replacement package)
           ;; XXX: If PACKAGE and its replacement have the same name/version,
           ;; then both Cuirass jobs will have the same name, which
           ;; effectively means that the second one will be ignored.  Thus,
           ;; return the replacement first.
           (cons* (package-replacement package)   ;build both
                  package
                  result))
          ((package-superseded package)
           result)                                ;don't build it
          (else
           (cons package result))))

  (fold-packages adjust
                 (fold adjust '()                 ;include base packages
                       (match (%final-inputs)
                         (((labels packages _ ...) ...)
                          packages)))
                 #:select? (const #t)))           ;include hidden packages

(define (arguments->manifests arguments channels)
  "Return the list of manifests extracted from ARGUMENTS."
  (map (lambda (manifest)
         (any (lambda (checkout)
                (let ((path (in-vicinity checkout manifest)))
                  (and (file-exists? path)
                       path)))
              (map channel-url channels)))
       arguments))

(define (manifests->packages store manifests)
  "Return the list of packages found in MANIFESTS."
  (define (load-manifest manifest)
    (save-module-excursion
     (lambda ()
       (set-current-module (make-user-module '((guix profiles) (gnu))))
       (primitive-load manifest))))

  (delete-duplicates!
   (map manifest-entry-item
        (append-map (compose manifest-entries
                             load-manifest)
                    manifests))))

(define (arguments->systems arguments)
  "Return the systems list from ARGUMENTS."
  (match (assoc-ref arguments 'systems)
    (#f              %cuirass-supported-systems)
    ((lst ...)       lst)
    ((? string? str) (call-with-input-string str read))))

;;;
;;; Cuirass entry point.
;;;

(define (cuirass-jobs store arguments)
  "Register Cuirass jobs."
  (define subset
    (assoc-ref arguments 'subset))

  (define systems
    (arguments->systems arguments))

  (define channels
    (let ((channels (assq-ref arguments 'channels)))
      (map sexp->channel channels)))

  (define guix
    (find guix-channel? channels))

  (define commit
    (channel-commit guix))

  (define source
    (channel-url guix))

  ;; Turn off grafts.  Grafting is meant to happen on the user's machines.
  (parameterize ((%graft? #f))
    ;; Return one job for each package, except bootstrap packages.
    (append-map
     (lambda (system)
       (format (current-error-port)
               "evaluating for '~a' (heap size: ~a MiB)...~%"
               system
               (round
                (/ (assoc-ref (gc-stats) 'heap-size)
                   (expt 2. 20))))
       (invalidate-derivation-caches!)
       (match subset
         ('all
          ;; Build everything, including replacements.
          (let ((all (all-packages))
                (job (lambda (package)
                       (package->job store package system))))
            (append
             (filter-map job all)
             (cross-jobs store system))))
         ('core
          ;; Build core packages only.
          (append
           (map (lambda (package)
                  (package-job store (job-name package)
                               package system))
                (append %bootstrap-packages %core-packages))
           (cross-jobs store system)))
         ('guix
          ;; Build Guix modules only.
          (guix-jobs store systems
                     #:source source
                     #:commit commit))
         ('hello
          ;; Build hello package only.
          (let ((hello (specification->package "hello")))
            (list (package-job store (job-name hello)
                               hello system))))
         ('images
          ;; Build Guix System images only.
          (image-jobs store system))
         ('system-tests
          ;; Build Guix System tests only.
          (system-test-jobs store system
                            #:source source
                            #:commit commit))
         ('tarball
          ;; Build Guix tarball only.
          (tarball-jobs store system))
         (('custom . modules)
          ;; Build custom modules jobs only.
          (append-map
           (lambda (module)
             (let ((proc (module-ref
                          (resolve-interface module)
                          'cuirass-jobs)))
               (proc store arguments)))
           modules))
         (('channels . channels)
          ;; Build only the packages from CHANNELS.
          (let ((all (all-packages)))
            (filter-map
             (lambda (package)
               (any (lambda (channel)
                      (and (member (channel-name channel) channels)
                           (package->job store package system)))
                    (package-channels package)))
             all)))
         (('packages . rest)
          ;; Build selected list of packages only.
          (let ((packages (map specification->package rest)))
            (map (lambda (package)
                   (package-job store (job-name package)
                                package system))
                 packages)))
         (('manifests . rest)
          ;; Build packages in the list of manifests.
          (let* ((manifests (arguments->manifests rest channels))
                 (packages (manifests->packages store manifests)))
            (map (lambda (package)
                   (package-job store (job-name package)
                                package system))
                 packages)))
         (else
          (error "unknown subset" subset))))
     systems)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 image)
  #:use-module (guix records)
  #:export (partition
            partition?
            partition-device
            partition-size
            partition-offset
            partition-file-system
            partition-file-system-options
            partition-label
            partition-uuid
            partition-flags
            partition-initializer

            image
            image?
            image-name
            image-format
            image-target
            image-size
            image-operating-system
            image-partitions
            image-compression?
            image-volatile-root?
            image-substitutable?

            image-type
            image-type?
            image-type-name
            image-type-constructor

            os->image))

;;;
;;; Partition record.
;;;

(define-record-type* <partition> partition make-partition
  partition?
  (device               partition-device (default #f))
  (size                 partition-size)
  (offset               partition-offset (default 0))
  (file-system          partition-file-system (default "ext4"))
  (file-system-options  partition-file-system-options
                        (default '()))
  (label                partition-label (default #f))
  (uuid                 partition-uuid (default #f))
  (flags                partition-flags (default '()))
  (initializer          partition-initializer (default #f)))

;;;
;;; Image record.
;;;

(define-record-type* <image>
  image make-image
  image?
  (name               image-name ;symbol
                      (default #f))
  (format             image-format) ;symbol
  (target             image-target
                      (default #f))
  (size               image-size  ;size in bytes as integer
                      (default 'guess))
  (operating-system   image-operating-system  ;<operating-system>
                      (default #f))
  (partitions         image-partitions ;list of <partition>
                      (default '()))
  (compression?       image-compression? ;boolean
                      (default #t))
  (volatile-root?     image-volatile-root? ;boolean
                      (default #t))
  (substitutable?     image-substitutable? ;boolean
                      (default #t)))

;;;
;;; Image type.
;;;

(define-record-type* <image-type>
  image-type make-image-type
  image-type?
  (name           image-type-name) ;symbol
  (constructor    image-type-constructor)) ;<operating-system> -> <image>

;;;
;;; Image creation.
;;;

(define* (os->image os #:key type)
  (let ((constructor (image-type-constructor type)))
    (constructor os)))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
;;;
;;; 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 installer)
  #:use-module (guix discovery)
  #:use-module (guix packages)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix utils)
  #:use-module (guix ui)
  #:use-module ((guix self) #:select (make-config.scm))
  #:use-module (guix packages)
  #:use-module (guix git-download)
  #:use-module (gnu installer utils)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages connman)
  #:use-module (gnu packages cryptsetup)
  #:use-module (gnu packages disk)
  #:use-module (gnu packages file-systems)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages guile-xyz)
  #:autoload   (gnu packages gnupg) (guile-gcrypt)
  #:use-module (gnu packages iso-codes)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages ncurses)
  #:use-module (gnu packages package-management)
  #:use-module (gnu packages xorg)
  #:use-module (gnu system locale)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (installer-program))

(define module-to-import?
  ;; Return true for modules that should be imported.  For (gnu system …) and
  ;; (gnu packages …) modules, we simply add the whole 'guix' package via
  ;; 'with-extensions' (to avoid having to rebuild it all), which is why these
  ;; modules are excluded here.
  (match-lambda
    (('guix 'config) #f)
    (('gnu 'installer _ ...) #t)
    (('gnu 'build _ ...) #t)
    (('guix 'build _ ...) #t)
    (_ #f)))

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

(define* (build-compiled-file name locale-builder)
  "Return a file-like object that evaluates the gexp LOCALE-BUILDER and store
its result in the scheme file NAME. The derivation will also build a compiled
version of this file."
  (define set-utf8-locale
    #~(begin
        (setenv "LOCPATH"
                #$(file-append glibc-utf8-locales "/lib/locale/"
                               (version-major+minor
                                (package-version glibc-utf8-locales))))
        (setlocale LC_ALL "en_US.utf8")))

  (define builder
    (with-extensions (list guile-json-3)
      (with-imported-modules `(,@(source-module-closure
                                  '((gnu installer locale))
                                  #:select? not-config?)
                               ((guix config) => ,(make-config.scm)))
        #~(begin
            (use-modules (gnu installer locale))

            ;; The locale files contain non-ASCII characters.
            #$set-utf8-locale

            (mkdir #$output)
            (let ((locale-file
                   (string-append #$output "/" #$name ".scm"))
                  (locale-compiled-file
                   (string-append #$output "/" #$name ".go")))
              (call-with-output-file locale-file
                (lambda (port)
                  (write #$locale-builder port)))
              (compile-file locale-file
                            #:output-file locale-compiled-file))))))
  (computed-file name builder))

(define apply-locale
  ;; Install the specified locale.
  (with-imported-modules (source-module-closure '((gnu services herd)))
    #~(lambda (locale)
        (false-if-exception
         (setlocale LC_ALL locale))

        ;; Restart the documentation viewer so it displays the manual in
        ;; language that corresponds to LOCALE.  Make sure that nothing is
        ;; printed on the console.
        (parameterize ((shepherd-message-port
                        (%make-void-port "w")))
          (stop-service 'term-tty2)
          (start-service 'term-tty2 (list locale))))))

(define* (compute-locale-step #:key
                              locales-name
                              iso639-languages-name
                              iso3166-territories-name)
  "Return a gexp that run the locale-page of INSTALLER, and install the
selected locale. The list of locales, languages and territories passed to
locale-page are computed in derivations named respectively LOCALES-NAME,
ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled,
so that when the installer is run, all the lengthy operations have already
been performed at build time."
  (define (compiled-file-loader file name)
    #~(load-compiled
       (string-append #$file "/" #$name ".go")))

  (let* ((supported-locales #~(supported-locales->locales
                               #+(glibc-supported-locales)))
         (iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/"))
         (iso639-3 #~(string-append #$iso-codes "iso_639-3.json"))
         (iso639-5 #~(string-append #$iso-codes "iso_639-5.json"))
         (iso3166 #~(string-append #$iso-codes "iso_3166-1.json"))
         (locales-file (build-compiled-file
                        locales-name
                        #~`(quote ,#$supported-locales)))
         (iso639-file (build-compiled-file
                       iso639-languages-name
                       #~`(quote ,(iso639->iso639-languages
                                   #$supported-locales
                                   #$iso639-3 #$iso639-5))))
         (iso3166-file (build-compiled-file
                        iso3166-territories-name
                        #~`(quote ,(iso3166->iso3166-territories #$iso3166))))
         (locales-loader (compiled-file-loader locales-file
                                               locales-name))
         (iso639-loader (compiled-file-loader iso639-file
                                              iso639-languages-name))
         (iso3166-loader (compiled-file-loader iso3166-file
                                               iso3166-territories-name)))
    #~(lambda (current-installer)
        (let ((result
               ((installer-locale-page current-installer)
                #:supported-locales #$locales-loader
                #:iso639-languages #$iso639-loader
                #:iso3166-territories #$iso3166-loader)))
          (#$apply-locale result)
          result))))

(define apply-keymap
  ;; Apply the specified keymap. Use the default keyboard model.
  #~(match-lambda
      ((layout variant options)
       (kmscon-update-keymap (default-keyboard-model)
                             layout variant options))))

(define* (compute-keymap-step context)
  "Return a gexp that runs the keymap-page of INSTALLER and install the
selected keymap."
  #~(lambda (current-installer)
      (let ((result
             (call-with-values
                 (lambda ()
                   (xkb-rules->models+layouts
                    (string-append #$xkeyboard-config
                                   "/share/X11/xkb/rules/base.xml")))
               (lambda (models layouts)
                 ((installer-keymap-page current-installer)
                  layouts '#$context)))))
        (and result (#$apply-keymap result))
        result)))

(define (installer-steps)
  (let ((locale-step (compute-locale-step
                      #:locales-name "locales"
                      #:iso639-languages-name "iso639-languages"
                      #:iso3166-territories-name "iso3166-territories"))
        (timezone-data #~(string-append #$tzdata
                                        "/share/zoneinfo/zone.tab")))
    #~(lambda (current-installer)
        ((installer-parameters-menu current-installer)
         (lambda ()
           ((installer-parameters-page current-installer)
            (lambda _
              (#$(compute-keymap-step 'param)
               current-installer)))))
        (list
         ;; Ask the user to choose a locale among those supported by
         ;; the glibc.  Install the selected locale right away, so that
         ;; the user may benefit from any available translation for the
         ;; installer messages.
         (installer-step
          (id 'locale)
          (description (G_ "Locale"))
          (compute (lambda _
                     (#$locale-step current-installer)))
          (configuration-formatter locale->configuration))

         ;; Welcome the user and ask them to choose between manual
         ;; installation and graphical install.
         (installer-step
          (id 'welcome)
          (compute (lambda _
                     ((installer-welcome-page current-installer)
                      #$(local-file "installer/aux-files/logo.txt")))))

         ;; Ask the user to select a timezone under glibc format.
         (installer-step
          (id 'timezone)
          (description (G_ "Timezone"))
          (compute (lambda _
                     ((installer-timezone-page current-installer)
                      #$timezone-data)))
          (configuration-formatter posix-tz->configuration))

         ;; The installer runs in a kmscon virtual terminal where loadkeys
         ;; won't work. kmscon uses libxkbcommon as a backend for keyboard
         ;; input. It is possible to update kmscon current keymap by sending
         ;; it a keyboard model, layout, variant and options, in a somehow
         ;; similar way as what is done with setxkbmap utility.
         ;;
         ;; So ask for a keyboard model, layout and variant to update the
         ;; current kmscon keymap.  For non-Latin layouts, we add an
         ;; appropriate second layout and toggle via Alt+Shift.
         (installer-step
          (id 'keymap)
          (description (G_ "Keyboard mapping selection"))
          (compute (lambda _
                     (#$(compute-keymap-step 'default)
                      current-installer)))
          (configuration-formatter keyboard-layout->configuration))

         ;; Ask the user to input a hostname for the system.
         (installer-step
          (id 'hostname)
          (description (G_ "Hostname"))
          (compute (lambda _
                     ((installer-hostname-page current-installer))))
          (configuration-formatter hostname->configuration))

         ;; Provide an interface above connmanctl, so that the user can select
         ;; a network susceptible to acces Internet.
         (installer-step
          (id 'network)
          (description (G_ "Network selection"))
          (compute (lambda _
                     ((installer-network-page current-installer)))))

         ;; Ask whether to enable substitute server discovery.
         (installer-step
          (id 'substitutes)
          (description (G_ "Substitute server discovery"))
          (compute (lambda _
                     ((installer-substitutes-page current-installer)))))

         ;; Prompt for users (name, group and home directory).
         (installer-step
          (id 'user)
          (description (G_ "User creation"))
          (compute (lambda _
                     ((installer-user-page current-installer))))
          (configuration-formatter users->configuration))

         ;; Ask the user to choose one or many desktop environment(s).
         (installer-step
          (id 'services)
          (description (G_ "Services"))
          (compute (lambda _
                     ((installer-services-page current-installer))))
          (configuration-formatter system-services->configuration))

         ;; Run a partitioning tool allowing the user to modify
         ;; partition tables, partitions and their mount points.
         ;; Do this last so the user has something to boot if any
         ;; of the previous steps didn't go as expected.
         (installer-step
          (id 'partition)
          (description (G_ "Partitioning"))
          (compute (lambda _
                     ((installer-partition-page current-installer))))
          (configuration-formatter user-partitions->configuration))

         (installer-step
          (id 'final)
          (description (G_ "Configuration file"))
          (compute
           (lambda (result prev-steps)
             ((installer-final-page current-installer)
              result prev-steps))))))))

(define (installer-program)
  "Return a file-like object that runs the given INSTALLER."
  (define init-gettext
    ;; Initialize gettext support, so that installer messages can be
    ;; translated.
    #~(begin
        (bindtextdomain "guix" (string-append #$guix "/share/locale"))
        (textdomain "guix")
        (setlocale LC_ALL "")))

  (define set-installer-path
    ;; Add the specified binary to PATH for later use by the installer.
    #~(let* ((inputs
              '#$(list bash ;start subshells
                       connman ;call connmanctl
                       cryptsetup
                       dosfstools ;mkfs.fat
                       e2fsprogs ;mkfs.ext4
                       lvm2-static ;dmsetup
                       btrfs-progs
                       jfsutils ;jfs_mkfs
                       ntfs-3g ;mkfs.ntfs
                       kbd ;chvt
                       guix ;guix system init call
                       util-linux ;mkwap
                       shadow
                       coreutils)))
        (with-output-to-port (%make-void-port "w")
          (lambda ()
            (set-path-environment-variable "PATH" '("bin" "sbin") inputs)))))

  (define steps (installer-steps))
  (define modules
    (scheme-modules*
     (string-append (current-source-directory) "/..")
     "gnu/installer"))

  (define installer-builder
    ;; Note: Include GUIX as an extension to get all the (gnu system …), (gnu
    ;; packages …), etc. modules.
    (with-extensions (list guile-gcrypt guile-newt
                           guile-parted guile-bytestructures
                           guile-json-3 guile-git guix)
      (with-imported-modules `(,@(source-module-closure
                                  `(,@modules
                                    (gnu services herd)
                                    (guix build utils))
                                  #:select? module-to-import?)
                               ((guix config) => ,(make-config.scm)))
        #~(begin
            (use-modules (gnu installer record)
                         (gnu installer keymap)
                         (gnu installer steps)
                         (gnu installer final)
                         (gnu installer hostname)
                         (gnu installer locale)
                         (gnu installer parted)
                         (gnu installer services)
                         (gnu installer timezone)
                         (gnu installer user)
                         (gnu installer utils)
                         (gnu installer newt)
                         ((gnu installer newt keymap)
                          #:select (keyboard-layout->configuration))
                         (gnu services herd)
                         (guix i18n)
                         (guix build utils)
                         ((system repl debug)
                          #:select (terminal-width))
                         (ice-9 match))

            ;; Initialize gettext support so that installers can use
            ;; (guix i18n) module.
            #$init-gettext

            ;; Add some binaries used by the installers to PATH.
            #$set-installer-path

            ;; Arrange for language and territory name translations to be
            ;; available.  We need them at run time, not just compile time,
            ;; because some territories have several corresponding languages
            ;; (e.g., "French" is always displayed as "français", but
            ;; "Belgium" could be translated to Dutch, French, or German.)
            (bindtextdomain "iso_639-3"           ;languages
                            #+(file-append iso-codes "/share/locale"))
            (bindtextdomain "iso_3166-1"          ;territories
                            #+(file-append iso-codes "/share/locale"))

            ;; Likewise for XKB keyboard layout names.
            (bindtextdomain "xkeyboard-config"
                            #+(file-append xkeyboard-config "/share/locale"))

            ;; Initialize 'terminal-width' in (system repl debug)
            ;; to a large-enough value to make backtrace more
            ;; verbose.
            (terminal-width 200)

            (let* ((current-installer newt-installer)
                   (steps (#$steps current-installer)))
              ((installer-init current-installer))

              (catch #t
                (lambda ()
                  (define results
                    (run-installer-steps
                     #:rewind-strategy 'menu
                     #:menu-proc (installer-menu-page current-installer)
                     #:steps steps))

                  (match (result-step results 'final)
                    ('success
                     ;; We did it!  Let's reboot!
                     (sync)
                     (stop-service 'root))
                    (_
                     ;; The installation failed, exit so that it is restarted
                     ;; by login.
                     #f)))
                (const #f)
                (lambda (key . args)
                  (syslog "crashing due to uncaught exception: ~s ~s~%"
                          key args)
                  (let ((error-file "/tmp/last-installer-error"))
                    (call-with-output-file error-file
                      (lambda (port)
                        (display-backtrace (make-stack #t) port)
                        (print-exception port
                                         (stack-ref (make-stack #t) 1)
                                         key args)))
                    ((installer-exit-error current-installer)
                     error-file key args))
                  (primitive-exit 1)))

              ((installer-exit current-installer)))))))

  (program-file
   "installer"
   #~(begin
       ;; Set the default locale to install unicode support.  For
       ;; some reason, unicode support is not correctly installed
       ;; when calling this in 'installer-builder'.
       (setenv "LANG" "en_US.UTF-8")
       (execl #$(program-file "installer-real" installer-builder
                              #:guile guile-3.0-latest)
              "installer-real"))))


code:
 ░░░                                     ░░░
 ░░▒▒░░░░░░░░░               ░░░░░░░░░▒▒░░
  ░░▒▒▒▒▒░░░░░░░           ░░░░░░░▒▒▒▒▒░
      ░▒▒▒░░▒▒▒▒▒         ░░░░░░░▒▒░
            ░▒▒▒▒░       ░░░░░░
             ▒▒▒▒▒      ░░░░░░
              ▒▒▒▒▒     ░░░░░
              ░▒▒▒▒▒   ░░░░░
               ▒▒▒▒▒   ░░░░░
                ▒▒▒▒▒ ░░░░░
                ░▒▒▒▒▒░░░░░
                 ▒▒▒▒▒▒░░░
                  ▒▒▒▒▒▒░
  _____ _   _ _    _    _____       _
 / ____| \ | | |  | |  / ____|     (_)
| |  __|  \| | |  | | | |  __ _   _ ___  __
| | |_ | . ' | |  | | | | |_ | | | | \ \/ /
| |__| | |\  | |__| | | |__| | |_| | |>  <
 \_____|_| \_|\____/   \_____|\__,_|_/_/\_\


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 installer connman)
  #:use-module (gnu installer utils)
  #:use-module (guix records)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (<technology>
            technology
            technology?
            technology-name
            technology-type
            technology-powered?
            technology-connected?

            <service>
            service
            service?
            service-name
            service-type
            service-path
            service-strength
            service-state

            &connman-error
            connman-error?
            connman-error-command
            connman-error-output
            connman-error-status

            &connman-connection-error
            connman-connection-error?
            connman-connection-error-service
            connman-connection-error-output

            &connman-password-error
            connman-password-error?

            &connman-already-connected-error
            connman-already-connected-error?

            connman-state
            connman-technologies
            connman-enable-technology
            connman-disable-technology
            connman-scan-technology
            connman-services
            connman-connect
            connman-disconnect
            connman-online?
            connman-connect-with-auth))

;;; Commentary:
;;;
;;; This module provides procedures for talking with the connman daemon.
;;; The best approach would have been using connman dbus interface.
;;; However, as Guile dbus bindings are not available yet, the console client
;;; "connmanctl" is used to talk with the daemon.
;;;

;;;
;;; Technology record.
;;;

;; The <technology> record encapsulates the "Technology" object of connman.
;; Technology type will be typically "ethernet", "wifi" or "bluetooth".

(define-record-type* <technology>
  technology make-technology
  technology?
  (name            technology-name) ; string
  (type            technology-type) ; string
  (powered?        technology-powered?) ; boolean
  (connected?      technology-connected?)) ; boolean

;;;
;;; Service record.
;;;

;; The <service> record encapsulates the "Service" object of connman.
;; Service type is the same as the technology it is associated to, path is a
;; unique identifier given by connman, strength describes the signal quality
;; if applicable. Finally, state is "idle", "failure", "association",
;; "configuration", "ready", "disconnect" or "online".

(define-record-type* <service>
  service make-service
  service?
  (name            service-name) ; string or #f
  (type            service-type) ; string
  (path            service-path) ; string
  (strength        service-strength) ; integer
  (state           service-state)) ; string

;;;
;;; Condition types.
;;;

(define-condition-type &connman-error &error
  connman-error?
  (command connman-error-command)
  (output connman-error-output)
  (status connman-error-status))

(define-condition-type &connman-connection-error &error
  connman-connection-error?
  (service connman-connection-error-service)
  (output  connman-connection-error-output))

(define-condition-type &connman-password-error &connman-connection-error
  connman-password-error?)

(define-condition-type &connman-already-connected-error
  &connman-connection-error connman-already-connected-error?)

;;;
;;; Procedures.
;;;

(define (connman-run command env arguments)
  "Run the given COMMAND, with the specified ENV and ARGUMENTS.  The error
output is discarded and &connman-error condition is raised if the command
returns a non zero exit code."
  (let* ((command `("env" ,env ,command ,@arguments "2>" "/dev/null"))
         (command-string (string-join command " "))
         (pipe (open-input-pipe command-string))
         (output (read-lines pipe))
         (ret (close-pipe pipe)))
    (case (status:exit-val ret)
      ((0) output)
      (else (raise (condition (&connman-error
                               (command command)
                               (output output)
                               (status ret))))))))

(define (connman . arguments)
  "Run connmanctl with the specified ARGUMENTS. Set the LANG environment
variable to C because the command output will be parsed and we don't want it
to be translated."
  (connman-run "connmanctl" "LANG=C" arguments))

(define (parse-keys keys)
  "Parse the given list of strings KEYS, under the following format:

     '((\"KEY = VALUE\") (\"KEY2 = VALUE2\") ...)

Return the corresponding association list of '((KEY . VALUE) (KEY2 . VALUE2)
...)  elements."
  (let ((key-regex (make-regexp "([^ ]+) = ([^$]+)")))
    (map (lambda (key)
           (let ((match-key (regexp-exec key-regex key)))
             (cons (match:substring match-key 1)
                   (match:substring match-key 2))))
         keys)))

(define (connman-state)
  "Return the state of connman. The nominal states are 'offline, 'idle,
'ready, 'oneline.  If an unexpected state is read, 'unknown is
returned. Finally, an error is raised if the connman output could not be
parsed, usually because the connman daemon is not responding."
  (let* ((output (connman "state"))
         (state-keys (parse-keys output)))
    (let ((state (assoc-ref state-keys "State")))
      (if state
          (cond ((string=? state "offline") 'offline)
                ((string=? state "idle") 'idle)
                ((string=? state "ready") 'ready)
                ((string=? state "online") 'online)
                (else 'unknown))
          (raise (condition
                  (&message
                   (message "Could not determine the state of connman."))))))))

(define (split-technology-list technologies)
  "Parse the given strings list TECHNOLOGIES, under the following format:

	'((\"/net/connman/technology/xxx\")
          (\"KEY = VALUE\")
          ...
          (\"/net/connman/technology/yyy\")
          (\"KEY2 = VALUE2\")
          ...)
 Return the corresponding '(((\"KEY = VALUE\") ...) ((\"KEY2 = VALUE2\") ...))
list so that each keys of a given technology are gathered in a separate list."
  (let loop ((result '())
             (cur-list '())
             (input (reverse technologies)))
    (if (null? input)
        result
        (let ((item (car input)))
          (if (string-match "/net/connman/technology" item)
              (loop (cons cur-list result) '() (cdr input))
              (loop result (cons item cur-list) (cdr input)))))))

(define (string->boolean string)
  (equal? string "True"))

(define (connman-technologies)
  "Return a list of available <technology> records."

  (define (technology-output->technology output)
    (let ((keys (parse-keys output)))
      (technology
       (name (assoc-ref keys "Name"))
       (type (assoc-ref keys "Type"))
       (powered? (string->boolean (assoc-ref keys "Powered")))
       (connected? (string->boolean (assoc-ref keys "Connected"))))))

  (let* ((output (connman "technologies"))
         (technologies (split-technology-list output)))
    (map technology-output->technology technologies)))

(define (connman-enable-technology technology)
  "Enable the given TECHNOLOGY."
  (let ((type (technology-type technology)))
    (connman "enable" type)))

(define (connman-disable-technology technology)
  "Disable the given TECHNOLOGY."
  (let ((type (technology-type technology)))
    (connman "disable" type)))

(define (connman-scan-technology technology)
  "Run a scan for the given TECHNOLOGY."
  (let ((type (technology-type technology)))
    (connman "scan" type)))

(define (connman-services)
  "Return a list of available <services> records."

  (define (service-output->service path output)
    (let* ((service-keys
            (match output
              ((_ . rest) rest)))
           (keys (parse-keys service-keys)))
      (service
       (name (assoc-ref keys "Name"))
       (type (assoc-ref keys "Type"))
       (path path)
       (strength (and=> (assoc-ref keys "Strength") string->number))
       (state (assoc-ref keys "State")))))

  (let* ((out (connman "services"))
         (out-filtered (delete "" out))
         (services-path (map (lambda (service)
                               (match (string-split service #\ )
                                 ((_ ... path) path)))
                             out-filtered))
         (services-output (map (lambda (service)
                                 (connman "services" service))
                               services-path)))
    (map service-output->service services-path services-output)))

(define (connman-connect service)
  "Connect to the given SERVICE."
  (let ((path (service-path service)))
    (connman "connect" path)))

(define (connman-disconnect service)
  "Disconnect from the given SERVICE."
  (let ((path (service-path service)))
    (connman "disconnect" path)))

(define (connman-online?)
  (let ((state (connman-state)))
    (eq? state 'online)))

(define (connman-connect-with-auth service password-proc)
  "Connect to the given SERVICE with the password returned by calling
PASSWORD-PROC. This is only possible in the interactive mode of connmanctl
because authentication is done by communicating with an agent.

As the open-pipe procedure of Guile do not allow to read from stderr, we have
to merge stdout and stderr using bash redirection. Then error messages are
extracted from connmanctl output using a regexp. This makes the whole
procedure even more unreliable.

Raise &connman-connection-error if an error occurred during connection. Raise
&connman-password-error if the given password is incorrect."

  (define connman-error-regexp (make-regexp "Error[ ]*([^\n]+)\n"))

  (define (match-connman-error str)
    (let ((match-error (regexp-exec connman-error-regexp str)))
      (and match-error (match:substring match-error 1))))

  (define* (read-regexps-or-error port regexps error-handler)
    "Read characters from port until an error is detected, or one of the given
REGEXPS is matched. If an error is detected, call ERROR-HANDLER with the error
string as argument. Raise an error if the eof is reached before one of the
regexps is matched."
    (let loop ((res ""))
      (let ((char (read-char port)))
        (cond
         ((eof-object? char)
          (raise (condition
                  (&message
                   (message "Unable to find expected regexp.")))))
         ((match-connman-error res)
          =>
          (lambda (match)
            (error-handler match)))
         ((or-map (lambda (regexp)
                    (and (regexp-exec regexp res) regexp))
                  regexps)
          =>
          (lambda (match)
            match))
         (else
          (loop (string-append res (string char))))))))

  (define* (read-regexp-or-error port regexp error-handler)
    "Same as READ-REGEXPS-OR-ERROR above, but with a single REGEXP."
    (read-regexps-or-error port (list regexp) error-handler))

  (define (connman-error->condition path error)
    (cond
     ((string-match "Already connected" error)
      (condition (&connman-already-connected-error
                  (service path)
                  (output error))))
     (else
      (condition (&connman-connection-error
                  (service path)
                  (output error))))))

  (define (run-connection-sequence pipe)
    "Run the connection sequence using PIPE as an opened port to an
interactive connmanctl process."
    (let* ((path (service-path service))
           (error-handler (lambda (error)
                            (raise
                             (connman-error->condition path error)))))
      ;; Start the agent.
      (format pipe "agent on\n")
      (read-regexp-or-error pipe (make-regexp "Agent registered") error-handler)

      ;; Let's try to connect to the service. If the service does not require
      ;; a password, the connection might succeed right after this call.
      ;; Otherwise, connmanctl will prompt us for a password.
      (format pipe "connect ~a\n" path)
      (let* ((connected-regexp (make-regexp (format #f "Connected ~a" path)))
             (passphrase-regexp (make-regexp "\nPassphrase\\?[ ]*"))
             (regexps (list connected-regexp passphrase-regexp))
             (result (read-regexps-or-error pipe regexps error-handler)))

        ;; A password is required.
        (when (eq? result passphrase-regexp)
          (format pipe "~a~%" (password-proc))

          ;; Now, we have to wait for the connection to succeed. If an error
          ;; occurs, it is most likely because the password is incorrect.
          ;; In that case, we escape from an eventual retry loop that would
          ;; add complexity to this procedure, and raise a
          ;; &connman-password-error condition.
          (read-regexp-or-error pipe connected-regexp
                                (lambda (error)
                                  ;; Escape from retry loop.
                                  (format pipe "no\n")
                                  (raise
                                   (condition (&connman-password-error
                                               (service path)
                                               (output error))))))))))

  ;; XXX: Find a better way to read stderr, like with the "subprocess"
  ;; procedure of racket that return input ports piped on the process stdin and
  ;; stderr.
  (let ((pipe (open-pipe "connmanctl 2>&1" OPEN_BOTH)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (setvbuf pipe 'line)
        (run-connection-sequence pipe)
        #t)
      (lambda ()
        (format pipe "quit\n")
        (close-pipe pipe)))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020 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 installer final)
  #:use-module (gnu installer newt page)
  #:use-module (gnu installer steps)
  #:use-module (gnu installer utils)
  #:use-module (gnu installer user)
  #:use-module (gnu services herd)
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (gnu build accounts)
  #:use-module (gnu build install)
  #:use-module (gnu build linux-container)
  #:use-module ((gnu system shadow) #:prefix sys:)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 rdelim)
  #:export (install-system))

(define %seed
  (seed->random-state
   (logxor (getpid) (car (gettimeofday)))))

(define (integer->alphanumeric-char n)
  "Map N, an integer in the [0..62] range, to an alphanumeric character."
  (cond ((< n 10)
         (integer->char (+ (char->integer #\0) n)))
        ((< n 36)
         (integer->char (+ (char->integer #\A) (- n 10))))
        ((< n 62)
         (integer->char (+ (char->integer #\a) (- n 36))))
        (else
         (error "integer out of bounds" n))))

(define (random-string len)
  "Compute a random string of size LEN where each character is alphanumeric."
  (let loop ((chars '())
             (len len))
    (if (zero? len)
        (list->string chars)
        (let ((n (random 62 %seed)))
          (loop (cons (integer->alphanumeric-char n) chars)
                (- len 1))))))

(define (create-user-database users root)
  "Create /etc/passwd, /etc/shadow, and /etc/group under ROOT for the given
USERS."
  (define etc
    (string-append root "/etc"))

  (define (salt)
    ;; "$6" gives us a SHA512 password hash; the random string must be taken
    ;; from the './0-9A-Za-z' alphabet (info "(libc) Passphrase Storage").
    (string-append "$6$" (random-string 10)))

  (define users*
    (map (lambda (user)
           (define root?
             (string=? "root" (user-name user)))

           (sys:user-account (name (user-name user))
                             (comment (user-real-name user))
                             (group "users")
                             (uid (if root? 0 #f))
                             (home-directory
                              (user-home-directory user))
                             (password (crypt (user-password user)
                                              (salt)))

                             ;; We need a string here, not a file-like, hence
                             ;; this choice.
                             (shell
                              "/run/current-system/profile/bin/bash")))
         users))

  (define-values (group password shadow)
    (user+group-databases users* sys:%base-groups
                          #:current-passwd '()
                          #:current-groups '()
                          #:current-shadow '()))

  (mkdir-p etc)
  (write-group group (string-append etc "/group"))
  (write-passwd password (string-append etc "/passwd"))
  (write-shadow shadow (string-append etc "/shadow")))

(define* (kill-cow-users cow-path #:key (spare '("udevd")))
  "Kill all processes that have references to the given COW-PATH in their
'maps' file.  The process whose names are in SPARE list are spared."
  (define %not-nul
    (char-set-complement (char-set #\nul)))

  (let ((pids
         (filter-map (lambda (pid)
                       (false-if-exception
                        (call-with-input-file
                            (string-append "/proc/" pid "/maps")
                          (lambda (port)
                            (and (string-contains (get-string-all port)
                                                  cow-path)
                                 (string->number pid))))))
                     (scandir "/proc" string->number))))
    (for-each (lambda (pid)
                ;; cmdline does not always exist.
                (false-if-exception
                 (call-with-input-file
                     (string-append "/proc/" (number->string pid) "/cmdline")
                   (lambda (port)
                     (match (string-tokenize (read-string port) %not-nul)
                       ((argv0 _ ...)
                        (unless (member (basename argv0) spare)
                          (syslog "Killing process ~a (~a)~%" pid argv0)
                          (kill pid SIGKILL)))
                       (_ #f))))))
              pids)))

(define (call-with-mnt-container thunk)
  "This is a variant of call-with-container. Run THUNK in a new container
process, within a separate MNT namespace. The container is not jailed so that
it can interact with the rest of the system."
  (let ((pid (run-container "/" '() '(mnt) 1 thunk)))
    ;; Catch SIGINT and kill the container process.
    (sigaction SIGINT
      (lambda (signum)
        (false-if-exception
         (kill pid SIGKILL))))

    (match (waitpid pid)
      ((_ . status) status))))

(define* (install-system locale #:key (users '()))
  "Create /etc/shadow and /etc/passwd on the installation target for USERS.
Start COW-STORE service on target directory and launch guix install command in
a subshell.  LOCALE must be the locale name under which that command will run,
or #f.  Return #t on success and #f on failure."
  (define backing-directory
    ;; Sub-directory used as the backing store for copy-on-write.
    "/tmp/guix-inst")

  (define (assert-exit x)
    (primitive-exit (if x 0 1)))

  (let* ((options         (catch 'system-error
                            (lambda ()
                              ;; If this file exists, it can provide
                              ;; additional command-line options.
                              (call-with-input-file
                                  "/tmp/installer-system-init-options"
                                read))
                            (const '())))
         (install-command (append (list "guix" "system" "init"
                                        "--fallback")
                                  options
                                  (list (%installer-configuration-file)
                                        (%installer-target-dir))))
         (database-dir    "/var/guix/db")
         (database-file   (string-append database-dir "/db.sqlite"))
         (saved-database  (string-append database-dir "/db.save"))
         (ret             #f))
    (mkdir-p (%installer-target-dir))

    ;; We want to initialize user passwords but we don't want to store them in
    ;; the config file since the password hashes would end up world-readable
    ;; in the store.  Thus, create /etc/shadow & co. here such that, on the
    ;; first boot, the activation snippet that creates accounts will reuse the
    ;; passwords that we've put in there.
    (create-user-database users (%installer-target-dir))

    ;; When the store overlay is mounted, other processes such as kmscon, udev
    ;; and guix-daemon may open files from the store, preventing the
    ;; underlying install support from being umounted. See:
    ;; https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html.
    ;;
    ;; To avoid this situation, mount the store overlay inside a container,
    ;; and run the installation from within that container.
    (zero?
     (call-with-mnt-container
       (lambda ()
         (dynamic-wind
           (lambda ()
             ;; Save the database, so that it can be restored once the
             ;; cow-store is umounted.
             (copy-file database-file saved-database)
             (mount-cow-store (%installer-target-dir) backing-directory))
           (lambda ()
             ;; We need to drag the guix-daemon to the container MNT
             ;; namespace, so that it can operate on the cow-store.
             (stop-service 'guix-daemon)
             (start-service 'guix-daemon (list (number->string (getpid))))

             (setvbuf (current-output-port) 'none)
             (setvbuf (current-error-port) 'none)

             ;; If there are any connected clients, assume that we are running
             ;; installation tests. In that case, dump the standard and error
             ;; outputs to syslog.
             (set! ret
                   (if (not (null? (current-clients)))
                       (with-output-to-file "/dev/console"
                         (lambda ()
                           (with-error-to-file "/dev/console"
                             (lambda ()
                               (run-command install-command
                                            #:locale locale)))))
                       (run-command install-command #:locale locale))))
           (lambda ()
             ;; Restart guix-daemon so that it does no keep the MNT namespace
             ;; alive.
             (restart-service 'guix-daemon)
             (copy-file saved-database database-file)

             ;; Finally umount the cow-store and exit the container.
             (unmount-cow-store (%installer-target-dir) backing-directory)
             (assert-exit ret))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 installer hostname)
  #:export (hostname->configuration))

(define (hostname->configuration hostname)
  `((host-name ,hostname)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
;;;
;;; 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 installer keymap)
  #:use-module (guix records)
  #:use-module (sxml match)
  #:use-module (sxml simple)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:export (<x11-keymap-model>
            x11-keymap-model
            make-x11-keymap-model
            x11-keymap-model?
            x11-keymap-model-name
            x11-keymap-model-description

            <x11-keymap-layout>
            x11-keymap-layout
            make-x11-keymap-layout
            x11-keymap-layout?
            x11-keymap-layout-name
            x11-keymap-layout-synopsis
            x11-keymap-layout-description
            x11-keymap-layout-variants

            <x11-keymap-variant>
            x11-keymap-variant
            make-x11-keymap-variant
            x11-keymap-variant?
            x11-keymap-variant-name
            x11-keymap-variant-description

            default-keyboard-model
            xkb-rules->models+layouts
            kmscon-update-keymap))

(define-record-type* <x11-keymap-model>
  x11-keymap-model make-x11-keymap-model
  x11-keymap-model?
  (name            x11-keymap-model-name) ;string
  (description     x11-keymap-model-description)) ;string

(define-record-type* <x11-keymap-layout>
  x11-keymap-layout make-x11-keymap-layout
  x11-keymap-layout?
  (name            x11-keymap-layout-name) ;string
  (synopsis        x11-keymap-layout-synopsis)    ;string (e.g., "en")
  (description     x11-keymap-layout-description) ;string (a whole phrase)
  (variants        x11-keymap-layout-variants)) ;list of <x11-keymap-variant>

(define-record-type* <x11-keymap-variant>
  x11-keymap-variant make-x11-keymap-variant
  x11-keymap-variant?
  (name            x11-keymap-variant-name) ;string
  (description     x11-keymap-variant-description)) ;string

;; Assume all modern keyboards have this model.
(define default-keyboard-model (make-parameter "pc105"))

(define (xkb-rules->models+layouts file)
  "Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL
and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard
Configuration Database, describing possible XKB configurations."
  (define (model m)
    (sxml-match m
                [(model
                  (configItem
                   (name ,name)
                   (description ,description)
                   . ,rest))
                 (x11-keymap-model
                  (name name)
                  (description description))]))

  (define (variant v)
    (sxml-match v
                [(variant
                  ;; According to xbd-rules DTD, the definition of a
                  ;; configItem is: <!ELEMENT configItem
                  ;; (name,shortDescription*,description*,vendor?,
                  ;; countryList?,languageList?,hwList?)>
                  ;;
                  ;; shortDescription and description are optional elements
                  ;; but sxml-match does not support default values for
                  ;; elements (only attributes). So to avoid writing as many
                  ;; patterns as existing possibilities, gather all the
                  ;; remaining elements but name in REST-VARIANT.
                  (configItem
                   (name ,name)
                   . ,rest-variant))
                 (x11-keymap-variant
                  (name name)
                  (description (car
                                (assoc-ref rest-variant 'description))))]))

  (define (layout l)
    (sxml-match l
                [(layout
                  (configItem
                   (name ,name)
                   . ,rest-layout)
                  (variantList ,[variant -> v] ...))
                 (x11-keymap-layout
                  (name name)
                  (synopsis (car
                             (assoc-ref rest-layout 'shortDescription)))
                  (description (car
                                (assoc-ref rest-layout 'description)))
                  (variants (list v ...)))]
                [(layout
                  (configItem
                   (name ,name)
                   . ,rest-layout))
                 (x11-keymap-layout
                  (name name)
                  (synopsis (car
                             (assoc-ref rest-layout 'shortDescription)))
                  (description (car
                                (assoc-ref rest-layout 'description)))
                  (variants '()))]))

  (let ((sxml (call-with-input-file file
                (lambda (port)
                  (xml->sxml port #:trim-whitespace? #t)))))
    (match
        (sxml-match sxml
                    [(*TOP*
                      ,pi
                      (xkbConfigRegistry
                       (@ . ,ignored)
                       (modelList ,[model -> m] ...)
                       (layoutList ,[layout -> l] ...)
                       . ,rest))
                     (list
                      (list m ...)
                      (list l ...))])
      ((models layouts)
       (values models layouts)))))

(define (kmscon-update-keymap model layout variant options)
  "Update kmscon keymap with the provided MODEL, LAYOUT, VARIANT and OPTIONS."
  (and=>
   (getenv "KEYMAP_UPDATE")
   (lambda (keymap-file)
     (unless (file-exists? keymap-file)
       (error "Unable to locate keymap update file"))

     ;; See file gnu/packages/patches/kmscon-runtime-keymap-switch.patch.
     ;; This dirty hack makes possible to update kmscon keymap at runtime by
     ;; writing an X11 keyboard model, layout and variant to a named pipe
     ;; referred by KEYMAP_UPDATE environment variable.
     (call-with-output-file keymap-file
       (lambda (port)
         (format port model)
         (put-u8 port 0)

         (format port layout)
         (put-u8 port 0)

         (format port (or variant ""))
         (put-u8 port 0)

         (format port (or options ""))
         (put-u8 port 0))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 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 installer locale)
  #:use-module (gnu installer utils)
  #:use-module ((gnu build locale) #:select (normalize-codeset))
  #:use-module (guix records)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:export (locale-language
            locale-territory
            locale-codeset
            locale-modifier

            locale->locale-string
            supported-locales->locales

            iso639->iso639-languages
            language-code->language-name

            iso3166->iso3166-territories
            territory-code->territory-name

            locale->configuration))

;;;
;;; Locale.
;;;

;; A glibc locale string has the following format:
;; language[_territory[.codeset][@modifier]].
(define locale-regexp "^([^_@]+)(_([^\\.@]+))?(\\.([^@]+))?(@([^$]+))?$")

;; LOCALE will be better expressed in a (guix record) that in an association
;; list. However, loading large files containing records does not scale
;; well. The same thing goes for ISO639 and ISO3166 association lists used
;; later in this module.
(define (locale-language assoc)
  (assoc-ref assoc 'language))
(define (locale-territory assoc)
  (assoc-ref assoc 'territory))
(define (locale-codeset assoc)
  (assoc-ref assoc 'codeset))
(define (locale-modifier assoc)
  (assoc-ref assoc 'modifier))

(define* (locale-string->locale string #:optional codeset)
  "Return the locale association list built from the parsing of STRING and,
optionally, CODESET."
  (let ((matches (string-match locale-regexp string)))
    `((language  . ,(match:substring matches 1))
      (territory . ,(match:substring matches 3))
      (codeset   . ,(or codeset (match:substring matches 5)))
      (modifier  . ,(match:substring matches 7)))))

(define (locale->locale-string locale)
  "Reverse operation of locale-string->locale."
  (let ((language (locale-language locale))
        (territory (locale-territory locale))
        (codeset (locale-codeset locale))
        (modifier (locale-modifier locale)))
    (apply string-append
           `(,language
             ,@(if territory
                   `("_" ,territory)
                   '())
             ,@(if codeset
                   `("." ,(normalize-codeset codeset))
                   '())
             ,@(if modifier
                   `("@" ,modifier)
                   '())))))

(define (supported-locales->locales supported-locales)
  "Given SUPPORTED-LOCALES, a file produced by 'glibc-supported-locales',
return a list of locales where each locale is an alist."
  (map (match-lambda
         ((locale . codeset)
          (locale-string->locale locale codeset)))
       (call-with-input-file supported-locales read)))

;;;
;;; Language.
;;;

(define (iso639-language-alpha2 assoc)
  (assoc-ref assoc 'alpha2))

(define (iso639-language-alpha3 assoc)
  (assoc-ref assoc 'alpha3))

(define (iso639-language-name assoc)
  (assoc-ref assoc 'name))

(define (supported-locale? locales alpha2 alpha3)
  "Find a locale in LOCALES whose alpha2 field matches ALPHA-2 or alpha3 field
matches ALPHA-3. The ISO639 standard specifies that ALPHA-2 is optional. Thus,
if ALPHA-2 is #f, only consider ALPHA-3. Return #f if not matching locale was
found."
  (find (lambda (locale)
          (let ((language (locale-language locale)))
            (or (and=> alpha2
                       (lambda (code)
                         (string=? language code)))
                (string=? language alpha3))))
        locales))

(define (iso639->iso639-languages locales iso639-3 iso639-5)
  "Return a list of ISO639 association lists created from the parsing of
ISO639-3 and ISO639-5 files."
  (call-with-input-file iso639-3
    (lambda (port-iso639-3)
      (call-with-input-file iso639-5
        (lambda (port-iso639-5)
          (filter-map
           (lambda (hash)
             (let ((alpha2 (assoc-ref hash "alpha_2"))
                   (alpha3 (assoc-ref hash "alpha_3"))
                   (name   (assoc-ref hash "name")))
               (and (supported-locale? locales alpha2 alpha3)
                    `((alpha2 . ,alpha2)
                      (alpha3 . ,alpha3)
                      (name   . ,name)))))
           (append
            (vector->list
             (assoc-ref (json->scm port-iso639-3) "639-3"))
            (vector->list
             (assoc-ref (json->scm port-iso639-5) "639-5")))))))))

(define (language-code->language-name languages language-code)
  "Using LANGUAGES as a list of ISO639 association lists, return the language
name corresponding to the given LANGUAGE-CODE."
  (let ((iso639-language
         (find (lambda (language)
                 (or
                  (and=> (iso639-language-alpha2 language)
                         (lambda (alpha2)
                           (string=? alpha2 language-code)))
                  (string=? (iso639-language-alpha3 language)
                            language-code)))
               languages)))
    (iso639-language-name iso639-language)))

;;;
;;; Territory.
;;;

(define (iso3166-territory-alpha2 assoc)
  (assoc-ref assoc 'alpha2))

(define (iso3166-territory-alpha3 assoc)
  (assoc-ref assoc 'alpha3))

(define (iso3166-territory-name assoc)
  (assoc-ref assoc 'name))

(define (iso3166->iso3166-territories iso3166)
  "Return a list of ISO3166 association lists created from the parsing of
ISO3166 file."
  (call-with-input-file iso3166
    (lambda (port)
      (map (lambda (hash)
             `((alpha2 . ,(assoc-ref hash "alpha_2"))
               (alpha3 . ,(assoc-ref hash "alpha_3"))
               (name   . ,(assoc-ref hash "name"))))
           (vector->list
            (assoc-ref (json->scm port) "3166-1"))))))

(define (territory-code->territory-name territories territory-code)
  "Using TERRITORIES as a list of ISO3166 association lists return the
territory name corresponding to the given TERRITORY-CODE."
  (let ((iso3166-territory
         (find (lambda (territory)
                 (or
                  (and=> (iso3166-territory-alpha2 territory)
                         (lambda (alpha2)
                           (string=? alpha2 territory-code)))
                  (string=? (iso3166-territory-alpha3 territory)
                            territory-code)))
               territories)))
    (iso3166-territory-name iso3166-territory)))

;;;
;;; Configuration formatter.
;;;

(define (locale->configuration locale)
  "Return the configuration field for LOCALE."
  `((locale ,locale)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 installer newt)
  #:use-module (gnu installer record)
  #:use-module (gnu installer utils)
  #:use-module (gnu installer newt ethernet)
  #:use-module (gnu installer newt final)
  #:use-module (gnu installer newt parameters)
  #:use-module (gnu installer newt hostname)
  #:use-module (gnu installer newt keymap)
  #:use-module (gnu installer newt locale)
  #:use-module (gnu installer newt menu)
  #:use-module (gnu installer newt network)
  #:use-module (gnu installer newt page)
  #:use-module (gnu installer newt partition)
  #:use-module (gnu installer newt services)
  #:use-module (gnu installer newt substitutes)
  #:use-module (gnu installer newt timezone)
  #:use-module (gnu installer newt user)
  #:use-module (gnu installer newt utils)
  #:use-module (gnu installer newt welcome)
  #:use-module (gnu installer newt wifi)
  #:use-module (guix config)
  #:use-module (guix discovery)
  #:use-module (guix i18n)
  #:use-module (srfi srfi-26)
  #:use-module (newt)
  #:export (newt-installer))

(define (init)
  (newt-init)
  (clear-screen)
  (set-screen-size!)
  (syslog "Display is ~ax~a.~%" (screen-columns) (screen-rows))
  (push-help-line
   (format #f (G_ "Press <F1> for installation parameters."))))

(define (exit)
  (newt-finish)
  (clear-screen))

(define (exit-error file key args)
  (newt-set-color COLORSET-ROOT "white" "red")
  (let ((width (nearest-exact-integer
                (* (screen-columns) 0.8)))
        (height (nearest-exact-integer
                 (* (screen-rows) 0.7))))
    (run-file-textbox-page
     #:info-text (format #f (G_ "The installer has encountered an unexpected \
problem. The backtrace is displayed below. Please report it by email to \
<~a>.") %guix-bug-report-address)
     #:title (G_ "Unexpected problem")
     #:file file
     #:exit-button? #f
     #:info-textbox-width width
     #:file-textbox-width width
     #:file-textbox-height height))
  (newt-set-color COLORSET-ROOT "white" "blue")
  (newt-finish)
  (clear-screen))

(define (final-page result prev-steps)
  (run-final-page result prev-steps))

(define* (locale-page #:key
                      supported-locales
                      iso639-languages
                      iso3166-territories)
  (run-locale-page
   #:supported-locales supported-locales
   #:iso639-languages iso639-languages
   #:iso3166-territories iso3166-territories))

(define (timezone-page zonetab)
  (run-timezone-page zonetab))

(define (welcome-page logo)
  (run-welcome-page logo))

(define (menu-page steps)
  (run-menu-page steps))

(define* (keymap-page layouts context)
  (run-keymap-page layouts #:context context))

(define (network-page)
  (run-network-page))

(define (substitutes-page)
  (run-substitutes-page))

(define (hostname-page)
  (run-hostname-page))

(define (user-page)
  (run-user-page))

(define (partition-page)
  (run-partitioning-page))

(define (services-page)
  (run-services-page))

(define (parameters-menu menu-proc)
  (newt-set-help-callback menu-proc))

(define (parameters-page keyboard-layout-selection)
  (run-parameters-page keyboard-layout-selection))

(define newt-installer
  (installer
   (name 'newt)
   (init init)
   (exit exit)
   (exit-error exit-error)
   (final-page final-page)
   (keymap-page keymap-page)
   (locale-page locale-page)
   (menu-page menu-page)
   (network-page network-page)
   (substitutes-page substitutes-page)
   (timezone-page timezone-page)
   (hostname-page hostname-page)
   (user-page user-page)
   (partition-page partition-page)
   (services-page services-page)
   (welcome-page welcome-page)
   (parameters-menu parameters-menu)
   (parameters-page parameters-page)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 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 installer newt ethernet)
  #:use-module (gnu installer connman)
  #:use-module (gnu installer steps)
  #:use-module (gnu installer newt utils)
  #:use-module (gnu installer newt page)
  #:use-module (guix i18n)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (newt)
  #:export (run-ethernet-page))

(define (ethernet-services)
  "Return all the connman services of ethernet type."
  (let ((services (connman-services)))
    (filter (lambda (service)
              (and (string=? (service-type service) "ethernet")
                   (not (string-null? (service-name service)))))
            services)))

(define (ethernet-service->text service)
  "Return a string describing the given ethernet SERVICE."
  (let* ((name (service-name service))
         (path (service-path service))
         (full-name (string-append name "-" path))
         (state (service-state service))
         (connected? (or (string=? state "online")
                         (string=? state "ready"))))
    (format #f "~c ~a~%"
            (if connected? #\* #\ )
            full-name)))

(define (connect-ethernet-service service)
  "Connect to the given ethernet SERVICE. Display a connecting page while the
connection is pending."
  (let* ((service-name (service-name service))
         (form (draw-connecting-page service-name)))
    (connman-connect service)
    (destroy-form-and-pop form)
    service))

(define (run-ethernet-page)
  (match (ethernet-services)
    (()
     (run-error-page
      (G_ "No ethernet service available, please try again.")
      (G_ "No service"))
     (raise
      (condition
       (&installer-step-abort))))
    ((service)
     ;; Only one service is available so return it directly.
     service)
    ((services ...)
     (run-listbox-selection-page
      #:info-text (G_ "Please select an ethernet network.")
      #:title (G_ "Ethernet connection")
      #:listbox-items services
      #:listbox-item->text ethernet-service->text
      #:listbox-height (min (+ (length services) 2) 5)
      #:button-text (G_ "Exit")
      #:button-callback-procedure
      (lambda _
        (raise
         (condition
          (&installer-step-abort))))
      #:listbox-callback-procedure connect-ethernet-service))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020 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 installer newt final)
  #:use-module (gnu installer final)
  #:use-module (gnu installer parted)
  #:use-module (gnu installer steps)
  #:use-module (gnu installer utils)
  #:use-module (gnu installer newt page)
  #:use-module (gnu installer newt utils)
  #:use-module (guix i18n)
  #:use-module (guix colors)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module (newt)
  #:export (run-final-page))

(define* (strip-prefix file #:optional (prefix (%installer-target-dir)))
  "Strip PREFIX from FILE, if PREFIX actually is a prefix of FILE."
  (if (string-prefix? prefix file)
      (string-drop file (string-length prefix))
      file))

(define* (run-config-display-page #:key locale)
  (let ((width (max 70 (- (screen-columns) 20)))
        (height (default-listbox-height)))
    (run-file-textbox-page
     #:info-text (format #f (G_ "\
We're now ready to proceed with the installation! \
A system configuration file has been generated, it is displayed below.  \
This file will be available as '~a' on the installed system.  \
The new system will be created from this file once you've pressed OK.  \
This will take a few minutes.")
                         (strip-prefix (%installer-configuration-file)))
     #:title (G_ "Configuration file")
     #:file (%installer-configuration-file)
     #:edit-button? #t
     #:editor-locale locale
     #:info-textbox-width width
     #:file-textbox-width width
     #:file-textbox-height height
     #:exit-button-callback-procedure
     (lambda ()
       (raise
        (condition
         (&installer-step-abort)))))))

(define (run-install-success-page)
  (match (current-clients)
    (()
     (message-window
      (G_ "Installation complete")
      (G_ "Reboot")
      (G_ "Congratulations!  Installation is now complete.  \
You may remove the device containing the installation image and \
press the button to reboot.")))
    (_
     ;; When there are clients connected, send them a message and keep going.
     (send-to-clients '(installation-complete))))

  ;; Return success so that the installer happily reboots.
  'success)

(define (run-install-failed-page)
  (match (current-clients)
    (()
     (match (choice-window
             (G_ "Installation failed")
             (G_ "Resume")
             (G_ "Restart the installer")
             (G_ "The final system installation step failed.  You can resume from \
a specific step, or restart the installer."))
       (1 (raise
           (condition
            (&installer-step-abort))))
       (2
        ;; Keep going, the installer will be restarted later on.
        #t)))
    (_
     (send-to-clients '(installation-failure))
     #t)))

(define* (run-install-shell locale
                            #:key (users '()))
  (clear-screen)
  (newt-suspend)
  (let ((install-ok? (install-system locale #:users users)))
    (newt-resume)
    install-ok?))

(define (run-final-page result prev-steps)
  (define (wait-for-clients)
    (unless (null? (current-clients))
      (syslog "waiting with clients before starting final step~%")
      (send-to-clients '(starting-final-step))
      (match (select (current-clients) '() '())
        (((port _ ...) _ _)
         (read-line port)))))

  ;; Before generating the configuration file, give clients a chance to do
  ;; things such as changing the swap partition label.
  (wait-for-clients)

  (syslog "proceeding with final step~%")
  (let* ((configuration   (format-configuration prev-steps result))
         (user-partitions (result-step result 'partition))
         (locale          (result-step result 'locale))
         (users           (result-step result 'user))
         (install-ok?
          (with-mounted-partitions
           user-partitions
           (configuration->file configuration)
           (run-config-display-page #:locale locale)
           (run-install-shell locale #:users users))))
    (if install-ok?
        (run-install-success-page)
        (run-install-failed-page))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 installer newt hostname)
  #:use-module (gnu installer newt page)
  #:use-module (guix i18n)
  #:export (run-hostname-page))

(define (run-hostname-page)
  (run-input-page (G_ "Please enter the system hostname.")
                  (G_ "Hostname")))