;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2014, 2015, 2018 Mark H Weaver ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2016, 2018 Efraim Flashner ;;; Copyright © 2016, 2023 Janneke Nieuwenhuizen ;;; Copyright © 2017 Kei Kebreau ;;; Copyright © 2018, 2022 Tobias Geerinckx-Rice ;;; Copyright © 2019 Julien Lepiller ;;; Copyright © 2019 Mathieu Othacehe ;;; ;;; 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 W
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@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)
  #:use-module (gnu installer record)
  #:use-module (gnu installer utils)
  #:use-module (gnu installer dump)
  #: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 kernel)
  #: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-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (newt)
  #:export (newt-installer))

(define (init)
  (newt-init)
  (clear-screen)
  (set-screen-size!)
  (installer-log-line "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 error)
  ;; Newt may be suspended in the context of the "install-system"
  ;; procedure. Resume it unconditionnally.
  (newt-resume)
  (newt-set-color COLORSET-ROOT "white" "red")
  (define action
    (run-textbox-page
     #:info-text (G_ "The installer has encountered an unexpected problem. \
The backtrace is displayed below. You may choose to exit or create a dump \
archive.")
     #:title (G_ "Unexpected problem")
     #:content error
     #:buttons-spec
     (list
      (cons (G_ "Dump") (const 'dump))
      (cons (G_ "Exit") (const 'exit)))))
  (newt-set-color COLORSET-ROOT "white" "blue")
  action)

(define (report-page dump-archive)
  (define text
    (format #f (G_ "The dump archive was created as ~a.  Would you like to \
send this archive to the Guix servers?") dump-archive))
  (define title (G_ "Dump archive created"))
  (when (run-confirmation-page text title)
    (let* ((uploaded-name (send-dump-report dump-archive))
           (text (if uploaded-name
                     (format #f (G_ "The dump was uploaded as ~a.  Please \
report it by email to ~a.") uploaded-name %guix-bug-report-address)
                     (G_ "The dump could not be uploaded."))))
      (run-error-page
       text
       (G_ "Dump upload result")))))

(define (dump-page dump-dir)
  (define files
    (scandir dump-dir (lambda (x)
                        (not (or (string=? x ".")
                                 (string=? x ".."))))))
  (fold (match-lambda*
          (((file . enable?) acc)
           (if enable?
               (cons file acc)
               acc)))
        '()
        (run-dump-page
         dump-dir
         (map (lambda (x)
                (cons x #f))
              files))))

(define (newt-run-command . args)
  (define command-output "")
  (define (line-accumulator line)
    (set! command-output
          (string-append/shared command-output line)))
  (define result (run-external-command-with-line-hooks (list line-accumulator)
                                                       args))
  (define exit-val (status:exit-val result))
  (define term-sig (status:term-sig result))
  (define stop-sig (status:stop-sig result))

  (if (and exit-val (zero? exit-val))
      #t
      (let ((info-text
             (cond
              (exit-val
               (format #f (G_ "External command ~s exited with code ~a")
                       args exit-val))
              (term-sig
               (format #f (G_ "External command ~s terminated by signal ~a")
                       args term-sig))
              (stop-sig
               (format #f (G_ "External command ~s stopped by signal ~a")
                       args stop-sig)))))
        (run-textbox-page #:title (G_ "External command error")
                          #:info-text info-text
                          #:content command-output
                          #:buttons-spec
                          (list
                           (cons "Ignore" (const #t))
                           (cons "Abort"
                                 (lambda ()
                                   (abort-to-prompt 'installer-step 'abort)))
                           (cons "Report"
                                 (lambda ()
                                   (raise
                                    (condition
                                     ((@@ (guix build utils)
                                          &invoke-error)
                                      (program (car args))
                                      (arguments (cdr args))
                                      (exit-status exit-val)
                                      (term-signal term-sig)
                                      (stop-signal stop-sig)))))))))))

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

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

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

(define* (welcome-page logo #:key pci-database)
  (run-welcome-page logo #:pci-database pci-database))

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

(define (keymap-page layouts context dry-run?)
  (run-keymap-page layouts #:context context #:dry-run? dry-run?))

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

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

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

(define (kernel-page)
  (run-kernel-page))

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

(define (partitioning-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)
   (kernel-page kernel-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)
   (partitioning-page partitioning-page)
   (services-page services-page)
   (welcome-page welcome-page)
   (parameters-menu parameters-menu)
   (parameters-page parameters-page)
   (dump-page dump-page)
   (run-command newt-run-command)
   (report-page report-page)))
generated by cgit
just skip them. #:tests? #f)) (native-inputs (list pkg-config)) (inputs `(("libxft" ,libxft) ("fontconfig" ,fontconfig) ("tcl" ,tcl))) ;; tk.h refers to X11 headers, hence the propagation. (propagated-inputs (list libx11 libxext)) (home-page "https://www.tcl.tk/") (synopsis "Graphical user interface toolkit for Tcl") (description "Tk is a graphical toolkit for building graphical user interfaces (GUIs) in the Tcl language.") (license (package-license tcl)))) (define-public perl-tk (package (name "perl-tk") (version "804.036") (source (origin (method url-fetch) (uri (string-append "mirror://cpan/authors/id/S/SR/SREZIC/Tk-" version ".tar.gz")) (sha256 (base32 "0pha40m97fzafjnq8vwkbi5sml6xv8jki6qi60rxrzmxlrqp5aij")))) (build-system perl-build-system) (native-inputs (list pkg-config)) (inputs `(("libx11" ,libx11) ("libpng" ,libpng) ("libjpeg" ,libjpeg-turbo))) (arguments `(#:make-maker-flags `(,(string-append "X11=" (assoc-ref %build-inputs "libx11"))) ;; Fails to build in parallel: . #:parallel-build? #f)) (synopsis "Graphical user interface toolkit for Perl") (description "Tk is a Graphical User Interface ToolKit.") (home-page "https://metacpan.org/release/Tk") ;; From the package README: "... you can redistribute it and/or modify it ;; under the same terms as Perl itself, with the exception of all the ;; files in the pTk sub-directory which have separate terms derived from ;; those of the orignal Tix4.1.3 or Tk8.4.* sources. See the files ;; pTk/license.terms, pTk/license.html_lib, and pTk/Tix.license for ;; details of this license." (license license:perl-license))) (define-public tcllib (package (name "tcllib") (version "1.19") (source (origin (method url-fetch) (uri (string-append "mirror://sourceforge/tcllib/tcllib/" version "/tcllib-" version ".tar.gz")) (sha256 (base32 "173abxaazdmf210v651708ab6h7xhskvd52krxk6ifam337qgzh1")))) (build-system gnu-build-system) (native-inputs (list tcl)) (native-search-paths (list (search-path-specification (variable "TCLLIBPATH") (separator " ") (files (list (string-append "lib/tcllib" version)))))) (home-page "https://core.tcl.tk/tcllib/home") (synopsis "Standard Tcl Library") (description "Tcllib, the standard Tcl library, is a collection of common utility functions and modules all written in high-level Tcl.") (license (package-license tcl)))) (define-public tklib (package (name "tklib") (version "0.6") (source (origin (method url-fetch) (uri (string-append "https://core.tcl.tk/tklib/tarball/tklib-" version ".tar.gz?uuid=tklib-0-6")) (sha256 (base32 "03y0bzgwbh7nnyqkh8n00bbkq2fyblq39s3bdb6mawna0bbn0wwg")))) (build-system gnu-build-system) (native-inputs (list tcl)) (propagated-inputs (list tcllib tk)) ; for "wish" (native-search-paths (list (search-path-specification (variable "TCLLIBPATH") (separator " ") (files (list (string-append "lib/tklib" version)))))) (home-page "https://www.tcl.tk/software/tklib/") (synopsis "Tk utility modules for Tcl") (description "Tklib is a collection of common utility functions and modules for Tk, all written in high-level Tcl. Examples of provided widgets: @enumerate @item @code{chatwidget} @item @code{datefield} @item @code{tooltip} @item @code{cursor} @item @code{ipentry} @item @code{tablelist} @item @code{history} @item @code{tkpiechart} @item @code{ico} @item @code{crosshair} @item @code{ntext} @item @code{plotchart} @item @code{ctext} @item @code{autosscroll} @item @code{canvas} @end enumerate") (license (package-license tcl)))) (define-public tclxml (package (name "tclxml") (version "3.2") (source (origin (method url-fetch) (uri (string-append "mirror://sourceforge/" name "/TclXML/" version "/" name "-" version ".tar.gz")) (sha256 (base32 "0ffb4aw63inig3aql33g4pk0kjk14dv238anp1scwjdjh1k6n4gl")) (patches (search-patches "tclxml-3.2-install.patch")))) (build-system gnu-build-system) (native-inputs (list tcl libxml2 libxslt)) (propagated-inputs (list tcllib)) ; uri (native-search-paths (list (search-path-specification (variable "TCLLIBPATH") (separator " ") (files (list (string-append "lib/Tclxml" version)))))) (arguments `(#:configure-flags (list (string-append "--exec-prefix=" (assoc-ref %outputs "out")) (string-append "--with-tclconfig=" (assoc-ref %build-inputs "tcl") "/lib") (string-append "--with-xml2-config=" (assoc-ref %build-inputs "libxml2") "/bin/xml2-config") (string-append "--with-xslt-config=" (assoc-ref %build-inputs "libxslt") "/bin/xslt-config")) #:test-target "test")) (home-page "https://tclxml.sourceforge.net/") (synopsis "Tcl library for XML parsing") (description "TclXML provides event-based parsing of XML documents. The application may register callback scripts for certain document features, and when the parser encounters those features while parsing the document the callback is evaluated.") (license (license:non-copyleft "file://LICENCE" "See LICENCE in the distribution.")))) (define-public tclx (package (name "tclx") (version "8.4.1") (source (origin (method url-fetch) (uri (string-append "mirror://sourceforge/tclx/TclX/" version "/tclx" version ".tar.bz2")) (sha256 (base32 "1v2qwzzidz0is58fd1p7wfdbscxm3ip2wlbqkj5jdhf6drh1zd59")))) (build-system gnu-build-system) (arguments '(#:tests? #f ; a test named profile.test segfaults #:configure-flags (list (string-append "--with-tcl=" (assoc-ref %build-inputs "tcl") "/lib") (string-append "--libdir=" (assoc-ref %outputs "out") "/lib")))) (inputs (list tcl tk)) (home-page "https://tclx.sourceforge.net/") (synopsis "System programming extensions for Tcl") (description "Extended Tcl is oriented towards system programming tasks and large application development. TclX provides additional interfaces to the operating system, and adds many new programming constructs, text manipulation tools, and debugging tools.") (license license:tcl/tk))) (define-public tcl-tls (package (name "tcl-tls") (version "1.7.22") (source (origin (method url-fetch) (uri (string-append "https://core.tcl-lang.org/tcltls/uv/tcltls-" version ".tar.gz")) (sha256 (base32 "1d639gzngxp7zwwpb4ayh663br6vhsbiy6wxm952rj2y4xx2nkp8")))) (build-system gnu-build-system) (inputs (list tcl)) (propagated-inputs (list openssl)) (arguments (list #:configure-flags #~(let ((tcl #$(this-package-input "tcl"))) (list "--with-ssl=libressl" (string-append "-with-ssl-dir=" #$(this-package-input "openssl")) (string-append "--with-tcl=" tcl "/lib") (string-append "--with-tclinclude=" tcl "/include") (string-append "--exec-prefix=" #$output) (string-append "--mandir=" #$output "/share/man"))) #:test-target "test")) (search-paths (list (search-path-specification (variable "TCLLIBPATH") (separator " ") (files (list (string-append "lib/tcltls" version)))))) (home-page "https://core.tcl-lang.org/tcltls/index") (synopsis "Tcl binding to OpenSSL toolkit") (description "This extension provides a generic binding to OpenSSL, utilizing the @code{Tcl_StackChannel} API for Tcl 8.2 and higher. The sockets behave exactly the same as channels created using Tcl's built-in socket command with additional options for controlling the SSL session.") (properties '((release-monitoring-url . "https://core.tcl-lang.org/tcltls/wiki/Download") (upstream-name . "tcltls"))) (license license:public-domain))) (define-public go-github.com-nsf-gothic (let ((commit "97dfcc195b9de36c911a69a6ec2b5b2659c05652") (revision "0")) (package (name "go-github.com-nsf-gothic") (version (git-version "0.0.0" revision commit)) (source (origin (method git-fetch) (uri (git-reference (url "https://github.com/nsf/gothic") (commit commit))) (sha256 (base32 "1lrhbml6r4sh22rrn3m9bck70pv0g0c1diprg7cil90x0jidxczr")) (file-name (git-file-name name version)))) (build-system go-build-system) (arguments `(#:import-path "github.com/nsf/gothic")) (propagated-inputs (list tk tcl)) (home-page "https://github.com/nsf/gothic") (synopsis "Tcl/Tk Go bindings") (description "Gothic contains Go bindings for Tcl/Tk. The package contains only one type and one function that can be used to create a Tk interpreter.") (license license:expat))))