From 62ca0fdf9e3b76f964bc953bfc39511c41be27b5 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 17 Jul 2014 15:53:01 +0200
Subject: services: Add 'console-font-service'.

* gnu/services/base.scm (unicode-start, console-font-service): New
  procedures.
  (%base-services): Call 'console-font-service' for TTY1 to TTY6.
* gnu/system/install.scm (installation-services): Add comment about the
  console font.  Call 'console-font-service' for TTY1 to TTY6.
---
 gnu/services/base.scm | 56 +++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 54 insertions(+), 2 deletions(-)

(limited to 'gnu/services')

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index a3944dbdfa..55ee5c4b08 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -25,7 +25,7 @@
   #:use-module (gnu system linux)                 ; 'pam-service', etc.
   #:use-module (gnu packages admin)
   #:use-module ((gnu packages linux)
-                #:select (udev))
+                #:select (udev kbd))
   #:use-module ((gnu packages base)
                 #:select (glibc-final))
   #:use-module (gnu packages package-management)
@@ -38,6 +38,7 @@
             file-system-service
             user-processes-service
             host-name-service
+            console-font-service
             udev-service
             mingetty-service
             nscd-service
@@ -199,6 +200,50 @@ stopped before 'kill' is called."
                         (sethostname #$name)))
              (respawn? #f)))))
 
+(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 (string-append #$kbd "/bin/unicode_start")
+                  "unicode_start"))
+          (else
+           (zero? (cdr (waitpid pid))))))))
+
+(define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
+  "Return a service that sets up Unicode support in @var{tty} and loads
+@var{font} for that tty (fonts are per virtual console in Linux.)"
+  ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
+  ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
+  ;; codepoints notably found in the UTF-8 manual.
+  (let ((device (string-append "/dev/" tty)))
+    (with-monad %store-monad
+      (return (service
+               (documentation "Load a Unicode console font.")
+               (provision (list (symbol-append 'console-font-
+                                               (string->symbol tty))))
+
+               ;; Start after mingetty has been started on TTY, otherwise the
+               ;; settings are ignored.
+               (requirement (list (symbol-append 'term-
+                                                 (string->symbol tty))))
+
+               (start #~(lambda _
+                          (and #$(unicode-start device)
+                               (zero?
+                                (system* (string-append #$kbd "/bin/setfont")
+                                         "-C" #$device #$font)))))
+               (stop #~(const #t))
+               (respawn? #f))))))
+
 (define* (mingetty-service tty
                            #:key
                            (motd (text-file "motd" "Welcome.\n"))
@@ -469,7 +514,14 @@ passed to @command{guix-daemon}."
   ;; Convenience variable holding the basic services.
   (let ((motd (text-file "motd" "
 This is the GNU operating system, welcome!\n\n")))
-    (list (mingetty-service "tty1" #:motd motd)
+    (list (console-font-service "tty1")
+          (console-font-service "tty2")
+          (console-font-service "tty3")
+          (console-font-service "tty4")
+          (console-font-service "tty5")
+          (console-font-service "tty6")
+
+          (mingetty-service "tty1" #:motd motd)
           (mingetty-service "tty2" #:motd motd)
           (mingetty-service "tty3" #:motd motd)
           (mingetty-service "tty4" #:motd motd)
-- 
cgit 1.4.1