Merge branch 'master' into gnome-team gnome-team

2 files changed, 64 insertions, 14 deletions

diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm
index 95c15907dd..19bdbdf6ae 100644
--- a/gnu/build/hurd-boot.scm
+++ b/gnu/build/hurd-boot.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2020, 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -105,7 +105,7 @@ Return the value associated with OPTION, or #f on failure."
 
   ;; TODO: Set the 'gnu.translator' extended attribute for passive translator
   ;; settings?
-  )
+  (mkdir-p (scope "servers/bus/pci")))
 
 (define (passive-translator-xattr? file-name)
   "Return true if FILE-NAME has an extended @code{gnu.translator} attribute
@@ -183,7 +183,8 @@ set."
        (mkdir-p dir))))
 
   (define servers
-    '(("servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
+    '(("servers/bus/pci"         ("/hurd/pci-arbiter"))
+      ("servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
       ("servers/crash-kill"      ("/hurd/crash" "--kill"))
       ("servers/crash-suspend"   ("/hurd/crash" "--suspend"))
       ("servers/password"        ("/hurd/password"))
@@ -213,6 +214,15 @@ set."
       ;; 'fd_to_filename' in libc expects it.
       ("dev/fd"      ("/hurd/magic"    "--directory" "fd")  #o555)
 
+      ("dev/rumpdisk" ("/hurd/rumpdisk")                    #o660)
+      ("dev/netdde"  ("/hurd/netdde")                       #o660)
+      ("dev/eth0"    ("/hurd/devnode" "--master-device=/dev/net"
+                      "eth0")
+                                                            #o660)
+      ("dev/eth1"    ("/hurd/devnode" "--master-device=/dev/net"
+                      "eth1")
+                                                            #o660)
+
       ;; Create a number of ttys; syslogd writes to tty12 by default.
       ;; FIXME: Creating /dev/tty12 leads the console client to switch to
       ;; tty12 when syslogd starts, which is confusing for users.  Thus, do
@@ -236,7 +246,22 @@ set."
                            ("/hurd/term" ,(string-append "/dev/ttyp" n)
                             "pty-slave" ,(string-append "/dev/ptyp" n))
                            #o666))))
-                    (iota 10 0))))
+                    (iota 10 0))
+      ,@(append-map (lambda (n)
+                      (let* ((n (number->string n))
+                             (drive (string-append "dev/wd" n))
+                             (disk (string-append "@/dev/disk:wd" n)))
+                        `((,drive ("/hurd/storeio" ,disk) #o600)
+                          ,@(map (lambda (p)
+                                   (let ((p (number->string p)))
+                                     `(,(string-append drive "s" p)
+                                       ("/hurd/storeio"
+                                        "--store-type=typed"
+                                        ,(string-append
+                                          "part:" p ":device:" disk))
+                                       #o660)))
+                                 (iota 4 1)))))
+                    (iota 4 0))))
 
   (for-each scope-set-translator servers)
   (mkdir* "dev/vcs/1")
@@ -249,6 +274,10 @@ set."
   (false-if-EEXIST (symlink "/dev/fd/1" (scope "dev/stdout")))
   (false-if-EEXIST (symlink "/dev/fd/2" (scope "dev/stderr")))
   (false-if-EEXIST (symlink "crash-dump-core" (scope "servers/crash")))
+  (false-if-EEXIST (symlink "/dev/rumpdisk" (scope "dev/disk")))
+  (false-if-EEXIST (symlink "/dev/netdde" (scope "dev/net")))
+  (false-if-EEXIST (symlink "/servers/socket/2" (scope "servers/socket/inet")))
+  (false-if-EEXIST (symlink "/servers/socket/26" (scope "servers/socket/inet6")))
 
   ;; Make sure /etc/mtab is a symlink to /proc/mounts.
   (false-if-exception (delete-file (scope "etc/mtab")))
diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm
index b8fba61d06..27c10e3dfe 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -1,7 +1,8 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
-;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -36,6 +37,7 @@
             wait-for-unix-socket
             marionette-control
             wait-for-screen-text
+            %default-ocrad-arguments
             %qwerty-us-keystrokes
             marionette-type
 
@@ -287,23 +289,30 @@ Monitor\")."
      ;; The "quit" command terminates QEMU immediately, with no output.
      (unless (string=? command "quit") (wait-for-monitor-prompt monitor)))))
 
-(define* (invoke-ocrad-ocr image #:key (ocrad "ocrad"))
+(define %default-ocrad-arguments
+  '("--invert" "--scale=10"))
+
+(define* (invoke-ocrad-ocr image #:key (ocrad "ocrad")
+                           (ocr-arguments %default-ocrad-arguments))
   "Invoke the OCRAD command on image, and return the recognized text."
-  (let* ((pipe (open-pipe* OPEN_READ ocrad "-i" "-s" "10" image))
+  (let* ((command (string-join `(,ocrad ,@ocr-arguments ,image)))
+         (pipe (open-input-pipe command))
          (text (get-string-all pipe)))
     (unless (zero? (close-pipe pipe))
       (error "'ocrad' failed" ocrad))
     text))
 
-(define* (invoke-tesseract-ocr image #:key (tesseract "tesseract"))
+(define* (invoke-tesseract-ocr image #:key (tesseract "tesseract")
+                               (ocr-arguments '()))
   "Invoke the TESSERACT command on IMAGE, and return the recognized text."
   (let* ((output-basename (tmpnam))
-         (output-basename* (string-append output-basename ".txt")))
+         (output-basename* (string-append output-basename ".txt"))
+         (arguments (cons* image output-basename ocr-arguments)))
     (dynamic-wind
       (const #t)
       (lambda ()
         (let ((exit-val (status:exit-val
-                         (system* tesseract image output-basename))))
+                         (apply system* tesseract arguments))))
           (unless (zero? exit-val)
             (error "'tesseract' failed" tesseract))
           (call-with-input-file output-basename* get-string-all)))
@@ -311,7 +320,8 @@ Monitor\")."
         (false-if-exception (delete-file output-basename))
         (false-if-exception (delete-file output-basename*))))))
 
-(define* (marionette-screen-text marionette #:key (ocr "ocrad"))
+(define* (marionette-screen-text marionette #:key (ocr "ocrad")
+                                 ocr-arguments)
   "Take a screenshot of MARIONETTE, perform optical character
 recognition (OCR), and return the text read from the screen as a string, along
 the screen dump image used.  Do this by invoking OCR, which should be the file
@@ -324,14 +334,22 @@ if it is not needed."
   ;; Process it via the OCR.
   (cond
    ((string-contains ocr "ocrad")
-    (values (invoke-ocrad-ocr image #:ocrad ocr) image))
+    (values (invoke-ocrad-ocr image
+                              #:ocrad ocr
+                              #:ocr-arguments
+                              (or ocr-arguments %default-ocrad-arguments))
+            image))
    ((string-contains ocr "tesseract")
-    (values (invoke-tesseract-ocr image #:tesseract ocr) image))
+    (values (invoke-tesseract-ocr image
+                                  #:tesseract ocr
+                                  #:ocr-arguments (or ocr-arguments '()))
+            image))
    (else (error "unsupported ocr command"))))
 
 (define* (wait-for-screen-text marionette predicate
                                #:key
                                (ocr "ocrad")
+                               ocr-arguments
                                (timeout 30)
                                pre-action
                                post-action)
@@ -359,7 +377,10 @@ Likewise for POST-ACTION, except it runs at the end of a successful OCR."
                  'ocr-text: last-text
                  'screendump: screendump-backup))
         (let* ((_ (and (procedure? pre-action) (pre-action)))
-               (text screendump (marionette-screen-text marionette #:ocr ocr))
+               (text screendump
+                     (marionette-screen-text marionette
+                                             #:ocr ocr
+                                             #:ocr-arguments ocr-arguments))
                (_ (and (procedure? post-action) (post-action)))
                (result (predicate text)))
           (cond (result