From 787e8a80d54d8bd5320d76276dc5f4bafe5b86c0 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 6 Dec 2017 08:52:31 +0100
Subject: services: console-font: Use 'tcsetattr' instead of invoking
 'unicode_start'.

This is more robust, faster, and incidentally gets rid of remaining
"error in the finalization thread: Bad file descriptor" messages.

* gnu/services/base.scm (unicode-start): Rewrite to use 'tcgetattr' and
'tcsetattr'.
(console-font-shepherd-services)[start]: Add 'loop' to check whether
DEVICE is ready.  Tolerate EX_OSERR return from 'setfont'.
[modules]: New field.
---
 gnu/services/base.scm | 56 ++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 38 insertions(+), 18 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 11f55c588c..291dd63256 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -621,21 +621,23 @@ to add @var{device} to the kernel's entropy pool.  The service will fail if
 
 (define (unicode-start tty)
   "Return a gexp to start Unicode support on @var{tty}."
-
-  ;; We have to run 'unicode_start' in a pipe so that when it invokes the
-  ;; 'tty' command, that command returns TTY.
-  #~(begin
-      (let ((pid (primitive-fork)))
-        (case pid
-          ((0)
-           (close-fdes 0)
-           (dup2 (open-fdes #$tty O_RDONLY) 0)
-           (close-fdes 1)
-           (dup2 (open-fdes #$tty O_WRONLY) 1)
-           (execl #$(file-append kbd "/bin/unicode_start")
-                  "unicode_start"))
-          (else
-           (zero? (cdr (waitpid pid))))))))
+  (with-imported-modules '((guix build syscalls))
+    #~(let* ((fd (open-fdes #$tty O_RDWR))
+             (termios (tcgetattr fd)))
+        (define (set-utf8-input termios)
+          (set-field termios (termios-input-flags)
+                     (logior (input-flags IUTF8)
+                             (termios-input-flags termios))))
+
+        ;; See console_codes(4).
+        (display "\x1b%G" (fdes->outport fd))
+
+        (tcsetattr fd (tcsetattr-action TCSAFLUSH)
+                   (set-utf8-input termios))
+
+        ;; TODO: ioctl(fd, KDSKBMODE, K_UNICODE);
+        (close-fdes fd)
+        #t)))
 
 (define console-keymap-service-type
   (shepherd-service-type
@@ -674,11 +676,29 @@ to add @var{device} to the kernel's entropy pool.  The service will fail if
              (requirement (list (symbol-append 'term-
                                                (string->symbol tty))))
 
+             (modules '((guix build syscalls)     ;for 'tcsetattr'
+                        (srfi srfi-9 gnu)))       ;for 'set-field'
              (start #~(lambda _
+                        ;; It could be that mingetty is not fully ready yet,
+                        ;; which we check by calling 'ttyname'.
+                        (let loop ((i 10))
+                          (unless (or (zero? i)
+                                      (call-with-input-file #$device
+                                        (lambda (port)
+                                          (false-if-exception (ttyname port)))))
+                            (usleep 500)
+                            (loop (- i 1))))
+
                         (and #$(unicode-start device)
-                             (zero?
-                              (system* #$(file-append kbd "/bin/setfont")
-                                       "-C" #$device #$font)))))
+                             ;; 'setfont' returns EX_OSERR (71) when an
+                             ;; KDFONTOP ioctl fails, for example.  Like
+                             ;; systemd's vconsole support, let's not treat
+                             ;; this as an error.
+                             (case (status:exit-val
+                                    (system* #$(file-append kbd "/bin/setfont")
+                                             "-C" #$device #$font))
+                               ((0 71) #t)
+                               (else #f)))))
              (stop #~(const #t))
              (respawn? #f)))))
        tty+font))
-- 
cgit 1.4.1