;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Leo Famulari ;;; Copyright © 2017 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 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 .
aboutsummaryrefslogtreecommitdiff
;;; 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 timezone)
  #:use-module (gnu installer utils)
  #: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 match)
  #:use-module (ice-9 receive)
  #:export (locate-children
            timezone->posix-tz
            timezone-has-child?
            zonetab->timezone-tree
            posix-tz->configuration))

(define %not-blank
  (char-set-complement char-set:blank))

(define (posix-tz->timezone tz)
  "Convert given TZ in Posix format like \"Europe/Paris\" into a list like
(\"Europe\" \"Paris\")."
  (string-split tz #\/))

(define (timezone->posix-tz timezone)
  "Convert given TIMEZONE like (\"Europe\" \"Paris\") into a Posix timezone
like \"Europe/Paris\"."
  (string-join timezone "/"))

(define (zonetab->timezones zonetab)
  "Parse ZONETAB file and return the corresponding list of timezones."

  (define (zonetab-line->posix-tz line)
    (let ((tokens (string-tokenize line %not-blank)))
      (match tokens
        ((code coordinates tz _ ...)
         tz))))

  (call-with-input-file zonetab
    (lambda (port)
      (let* ((lines (read-lines port))
             ;; Filter comment lines starting with '#' character.
             (tz-lines (filter (lambda (line)
                                 (not (eq? (string-ref line 0)
                                           #\#)))
                               lines)))
        (map (lambda (line)
               (posix-tz->timezone
                (zonetab-line->posix-tz line)))
             tz-lines)))))

(define (timezones->timezone-tree timezones)
  "Convert the list of timezones, TIMEZONES into a tree under the form:

	(\"America\" (\"North_Dakota\" \"New_Salem\" \"Center\"))

representing America/North_Dakota/New_Salem and America/North_Dakota/Center
timezones."

  (define (remove-first lists)
    "Remove the first element of every sublists in the argument LISTS."
    (map (lambda (list)
           (if (null? list) list (cdr list)))
         lists))

  (let loop ((cur-timezones timezones))
    (match cur-timezones
      (() '())
      (((region . rest-region) . rest-timezones)
       (if (null? rest-region)
           (cons (list region) (loop rest-timezones))
           (receive (same-region other-region)
               (partition (lambda (timezone)
                            (string=? (car timezone) region))
                          cur-timezones)
             (acons region
                    (loop (remove-first same-region))
                    (loop other-region))))))))

(define (locate-children tree path)
  "Return the children of the timezone indicated by PATH in the given
TREE. Raise a condition if the PATH could not be found."
  (let ((extract-proc (cut map car <>)))
    (match path
      (() (sort (extract-proc tree) string<?))
      ((region . rest)
       (or (and=> (assoc-ref tree region)
                  (cut locate-children <> rest))
           (raise
            (condition
             (&message
              (message
               (format #f (G_ "Unable to locate path: ~a.") path))))))))))

(define (timezone-has-child? tree timezone)
  "Return #t if the given TIMEZONE any child in TREE and #f otherwise."
  (not (null? (locate-children tree timezone))))

(define* (zonetab->timezone-tree zonetab)
  "Return the timezone tree corresponding to the given ZONETAB file."
  (timezones->timezone-tree (zonetab->timezones zonetab)))

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

(define (posix-tz->configuration timezone)
  "Return the configuration field for TIMEZONE."
  `((timezone ,timezone)))
generated by cgit
#$(grub-setup-io config) #$(strip-mount-point store-mount-point image) #$(theme-colors grub-theme-color-normal) #$(theme-colors grub-theme-color-highlight)))) ;;; ;;; Configuration file. ;;; (define (grub-setup-io config) "Return GRUB commands to configure the input / output interfaces. The result is a string that can be inserted in grub.cfg." (let* ((symbols->string (lambda (list) (string-join (map symbol->string list) " "))) (outputs (bootloader-configuration-terminal-outputs config)) (inputs (bootloader-configuration-terminal-inputs config)) (unit (bootloader-configuration-serial-unit config)) (speed (bootloader-configuration-serial-speed config)) ;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT, ;; as documented in GRUB manual section "Simple Configuration ;; Handling". (valid-outputs '(console serial serial_0 serial_1 serial_2 serial_3 gfxterm vga_text mda_text morse spkmodem)) (valid-inputs '(console serial serial_0 serial_1 serial_2 serial_3 at_keyboard usb_keyboard)) (io (string-append "terminal_output " (symbols->string (map (lambda (output) (if (memq output valid-outputs) output #f)) outputs)) "\n" (if (null? inputs) "" (string-append "terminal_input " (symbols->string (map (lambda (input) (if (memq input valid-inputs) input #f)) inputs)) "\n")) ;; UNIT and SPEED are arguments to the same GRUB command ;; ("serial"), so we process them together. (if (or unit speed) (string-append "serial" (if unit ;; COM ports 1 through 4 (if (and (exact-integer? unit) (<= unit 3) (>= unit 0)) (string-append " --unit=" (number->string unit)) #f) "") (if speed (if (exact-integer? speed) (string-append " --speed=" (number->string speed)) #f) "")) "")))) (format #f "~a" io))) (define (grub-root-search device file) "Return the GRUB 'search' command to look for DEVICE, which contains FILE, a gexp. The result is a gexp that can be inserted in the grub.cfg-generation code." ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of ;; custom menu entries. In the latter case, don't emit a 'search' command. (if (and (string? file) (not (string-prefix? "/" file))) "" (match device ;; Preferably refer to DEVICE by its UUID or label. This is more ;; efficient and less ambiguous, see . ((? uuid? uuid) (format #f "search --fs-uuid --set ~a" (uuid->string device))) ((? file-system-label? label) (format #f "search --label --set ~a" (file-system-label->string label))) ((or #f (? string?)) #~(format #f "search --file --set ~a" #$file))))) (define* (grub-configuration-file config entries #:key (system (%current-system)) (old-entries '())) "Return the GRUB configuration file corresponding to CONFIG, a object, and where the store is available at STORE-FS, a object. OLD-ENTRIES is taken to be a list of menu entries corresponding to old generations of the system." (define all-entries (append entries (bootloader-configuration-menu-entries config))) (define (menu-entry->gexp entry) (let ((device (menu-entry-device entry)) (device-mount-point (menu-entry-device-mount-point entry)) (label (menu-entry-label entry)) (kernel (menu-entry-linux entry)) (arguments (menu-entry-linux-arguments entry)) (initrd (menu-entry-initrd entry))) ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point. ;; Use the right file names for KERNEL and INITRD in case ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a ;; separate partition. (let ((kernel (strip-mount-point device-mount-point kernel)) (initrd (strip-mount-point device-mount-point initrd))) #~(format port "menuentry ~s { ~a linux ~a ~a initrd ~a }~%" #$label #$(grub-root-search device kernel) #$kernel (string-join (list #$@arguments)) #$initrd)))) (define sugar (eye-candy config (menu-entry-device (first all-entries)) (menu-entry-device-mount-point (first all-entries)) #:system system #:port #~port)) (define builder #~(call-with-output-file #$output (lambda (port) (format port "# This file was generated from your GuixSD configuration. Any changes # will be lost upon reconfiguration. ") #$sugar (format port " set default=~a set timeout=~a~%" #$(bootloader-configuration-default-entry config) #$(bootloader-configuration-timeout config)) #$@(map menu-entry->gexp all-entries) #$@(if (pair? old-entries) #~((format port " submenu \"GNU system, old configurations...\" {~%") #$@(map menu-entry->gexp old-entries) (format port "}~%")) #~())))) (computed-file "grub.cfg" builder)) ;;; ;;; Install procedures. ;;; (define install-grub #~(lambda (bootloader device mount-point) ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT. (let ((grub (string-append bootloader "/sbin/grub-install")) (install-dir (string-append mount-point "/boot"))) ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or ;; root partition. (setenv "GRUB_ENABLE_CRYPTODISK" "y") (unless (zero? (system* grub "--no-floppy" "--target=i386-pc" "--boot-directory" install-dir device)) (error "failed to install GRUB (BIOS)"))))) (define install-grub-efi #~(lambda (bootloader efi-dir mount-point) ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the ;; system whose root is mounted at MOUNT-POINT. (let ((grub-install (string-append bootloader "/sbin/grub-install")) (install-dir (string-append mount-point "/boot")) ;; When installing GuixSD, it's common to mount EFI-DIR below ;; MOUNT-POINT rather than /boot/efi on the live image. (target-esp (if (file-exists? (string-append mount-point efi-dir)) (string-append mount-point efi-dir) efi-dir))) ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or ;; root partition. (setenv "GRUB_ENABLE_CRYPTODISK" "y") (unless (zero? (system* grub-install "--boot-directory" install-dir "--bootloader-id=GuixSD" "--efi-directory" target-esp)) (error "failed to install GRUB (EFI)"))))) ;;; ;;; Bootloader definitions. ;;; (define grub-bootloader (bootloader (name 'grub) (package grub) (installer install-grub) (configuration-file "/boot/grub/grub.cfg") (configuration-file-generator grub-configuration-file))) (define* grub-efi-bootloader (bootloader (inherit grub-bootloader) (installer install-grub-efi) (name 'grub-efi) (package grub-efi))) (define* grub-mkrescue-bootloader (bootloader (inherit grub-efi-bootloader) (package grub-hybrid))) ;;; ;;; Compatibility macros. ;;; (define-syntax grub-configuration (syntax-rules (grub) ((_ (grub package) fields ...) (if (eq? package grub) (bootloader-configuration (bootloader grub-bootloader) fields ...) (bootloader-configuration (bootloader grub-efi-bootloader) fields ...))) ((_ fields ...) (bootloader-configuration (bootloader grub-bootloader) fields ...)))) ;;; grub.scm ends here