aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2022 Ludovic Courtès <ludo@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 (test-status)
  #:use-module (guix status)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (srfi srfi-71)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match))

(test-begin "status")

(test-equal "compute-status, no-op"
  (build-status)
  (let ((port get-status (build-event-output-port compute-status)))
    (display "foo\nbar\n\baz\n" port)
    (get-status)))

(test-equal "compute-status, builds + substitutes"
  (list (build-status
         (building (list (build "foo.drv" "x86_64-linux")))
         (downloading (list (download "bar" "http://example.org/bar"
                                      #:size 500
                                      #:start 'now))))
        (build-status
         (building (list (build "foo.drv" "x86_64-linux")))
         (downloading (list (download "bar" "http://example.org/bar"
                                      #:size 500
                                      #:transferred 42
                                      #:start 'now))))
        (build-status
         (builds-completed (list (build "foo.drv" "x86_64-linux")))
         (downloads-completed (list (download "bar" "http://example.org/bar"
                                              #:size 500
                                              #:transferred 500
                                              #:start 'now
                                              #:end 'now)))))
  (let ((port get-status
              (build-event-output-port (lambda (event status)
                                         (compute-status event status
                                                         #:current-time
                                                         (const 'now))))))
    (display "@ build-started foo.drv - x86_64-linux \n" port)
    (display "@ substituter-started bar\n" port)
    (display "@ download-started bar http://example.org/bar 500\n" port)
    (display "various\nthings\nget\nwritten\n" port)
    (let ((first (get-status)))
      (display "@ download-progress bar http://example.org/bar 500 42\n"
               port)
      (let ((second (get-status)))
        (display "@ download-progress bar http://example.org/bar 500 84\n"
                 port)
        (display "@ build-succeeded foo.drv\n" port)
        (display "@ download-succeeded bar http://example.org/bar 500\n" port)
        (display "Almost done!\n" port)
        (display "@ substituter-succeeded bar\n" port)
        (list first second (get-status))))))

(test-equal "compute-status, missing events"
  (list (build-status
         (building (list (build "foo.drv" "x86_64-linux"
                                #:log-file "foo.log")))
         (downloading (list (download "baz" "http://example.org/baz"
                                      #:size 500
                                      #:transferred 42
                                      #:start 'now)
                            (download "bar" "http://example.org/bar"
                                      #:size 999
                                      #:transferred 0
                                      #:start 'now))))
        (build-status
         (builds-completed (list (build "foo.drv" "x86_64-linux"
                                        #:log-file "foo.log")))
         (downloads-completed (list (download "baz" "http://example.org/baz"
                                              #:size 500
                                              #:transferred 500
                                              #:start 'now
                                              #:end 'now)
                                    (download "bar" "http://example.org/bar"
                                              #:size 999
                                              #:transferred 999
                                              #:start 'now
                                              #:end 'now)))))
  ;; Below we omit 'substituter-started' events and the like.
  (let ((port get-status
              (build-event-output-port (lambda (event status)
                                         (compute-status event status
                                                         #:current-time
                                                         (const 'now))))))
    (display "@ build-started foo.drv - x86_64-linux foo.log\n" port)
    (display "@ download-started bar http://example.org/bar 999\n" port)
    (display "various\nthings\nget\nwritten\n" port)
    (display "@ download-progress baz http://example.org/baz 500 42\n"
             port)
    (let ((first (get-status)))
      (display "@ build-succeeded foo.drv\n" port)
      (display "@ download-succeeded bar http://example.org/bar 999\n" port)
      (display "Almost done!\n" port)
      (display "@ substituter-succeeded baz\n" port)
      (list first (get-status)))))

(test-equal "build-output-port, UTF-8"
  '((build-log #f "lambda is λ!\n"))
  (let ((port get-status (build-event-output-port cons '()))
        (bv              (string->utf8 "lambda is λ!\n")))
    (put-bytevector port bv)
    (force-output port)
    (get-status)))

(test-equal "build-output-port, daemon messages with LF"
  '((build-log #f "updating substitutes... 0%\r")
    (build-log #f "updating substitutes... 50%\r")
    (build-log #f "updating substitutes... 100%\r"))
  (let ((port get-status (build-event-output-port cons '())))
    (for-each (lambda (suffix)
                (let ((bv (string->utf8
                           (string-append "updating substitutes... "
                                          suffix "\r"))))
                  (put-bytevector port bv)
                  (force-output port)))
              '("0%" "50%" "100%"))
    (reverse (get-status))))

(test-equal "current-build-output-port, UTF-8 + garbage"
  ;; What about a mixture of UTF-8 + garbage?
  (let ((replacement "�"))
    `((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n"))))
  (let ((port get-status (build-event-output-port cons '())))
    (display "garbage: " port)
    (put-bytevector port #vu8(128))
    (put-bytevector port (string->utf8 "lambda: λ\n"))
    (force-output port)
    (get-status)))

(test-equal "compute-status, multiplexed build output"
  (list (build-status
         (building (list (build "foo.drv" "x86_64-linux" #:id 121)))
         (downloading (list (download "bar" "http://example.org/bar"
                                      #:size 999
                                      #:start 'now))))
        (build-status
         (building (list (build "foo.drv" "x86_64-linux" #:id 121)))
         (downloading (list (download "bar" "http://example.org/bar"
                                      #:size 999
                                      #:transferred 42
                                      #:start 'now))))
        (build-status
         ;; "bar" is now only listed as a download.
         (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121)))
         (downloads-completed (list (download "bar" "http://example.org/bar"
                                              #:size 999
                                              #:transferred 999
                                              #:start 'now
                                              #:end 'now)))))
  (let ((port get-status
              (build-event-output-port (lambda (event status)
                                         (compute-status event status
                                                         #:current-time
                                                         (const 'now)
                                                         #:derivation-path->output-path
                                                         (match-lambda
                                                           ("bar.drv" "bar")))))))
    (display "@ build-started foo.drv - x86_64-linux  121\n" port)
    (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port)
    (display "@ build-log 121 6\nHello!" port)
    (display "@ build-log 144 50
@ download-started bar http://example.org/bar 999\n" port)
    (let ((first (get-status)))
      (display "@ build-log 121 30\n@ build-started FAKE!.drv 555\n")
      (display "@ build-log 144 54
@ download-progress bar http://example.org/bar 999 42\n"
               port)
      (let ((second (get-status)))
        (display "@ download-succeeded bar http://example.org/bar 999\n" port)
        (display "@ build-succeeded foo.drv\n" port)
        (display "@ build-succeeded bar.drv\n" port)
        (list first second (get-status))))))

(test-equal "compute-status, build completion"
  (list (build-status
         (building (list (build "foo.drv" "x86_64-linux" #:id 121))))
        (build-status
         (building (list (build "foo.drv" "x86_64-linux" #:id 121
                                #:completion 0.))))
        (build-status
         (building (list (build "foo.drv" "x86_64-linux" #:id 121
                                #:completion 50.))))
        (build-status
         (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121
                                        #:completion 100.)))))
  (let ((port get-status
              (build-event-output-port (lambda (event status)
                                         (compute-status event status
                                                         #:current-time
                                                         (const 'now))))))
    (display "@ build-started foo.drv - x86_64-linux  121\n" port)
    (display "@ build-log 121 6\nHello!" port)
    (let ((first (get-status)))
      (display "@ build-log 121 20\n[ 0/100] building X\n" port)
      (display "@ build-log 121 6\nHello!" port)
      (let ((second (get-status)))
        (display "@ build-log 121 20\n[50/100] building Y\n" port)
        (display "@ build-log 121 6\nHello!" port)
        (let ((third (get-status)))
          (display "@ build-log 121 21\n[100/100] building Z\n" port)
          (display "@ build-log 121 6\nHello!" port)
          (display "@ build-succeeded foo.drv\n" port)
          (list first second third (get-status)))))))

(test-equal "compute-status, build phase"
  (list (build-status
         (building (list (build "foo.drv" "x86_64-linux" #:id 121
                                #:phase 'configure))))
        (build-status
         (building (list (build "foo.drv" "x86_64-linux" #:id 121
                                #:phase 'configure
                                #:completion 50.))))
        (build-status
         (building (list (build "foo.drv" "x86_64-linux" #:id 121
                                #:phase 'install))))
        (build-status
         (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121
                                        #:phase 'install)))))
  (let ((port get-status
              (build-event-output-port (lambda (event status)
                                         (compute-status event status
                                                         #:current-time
                                                         (const 'now))))))
    (display "@ build-started foo.drv - x86_64-linux  121\n" port)
    (display "@ build-log 121 27\nstarting phase `configure'\n" port)
    (display "@ build-log 121 6\nabcde!" port)
    (let ((first (get-status)))
      (display "@ build-log 121 20\n[50/100] building Y\n" port)
      (display "@ build-log 121 6\nfghik!" port)
      (let ((second (get-status)))
        (display "@ build-log 121 21\n[100/100] building Z\n" port)
        (display "@ build-log 121 25\nstarting phase `install'\n" port)
        (display "@ build-log 121 6\nlmnop!" port)
        (let ((third (get-status)))
          (display "@ build-succeeded foo.drv\n" port)
          (list first second third (get-status)))))))

(test-end "status")
generated by cgit
m (patchwork-os): Update accordingly. * doc/guix.texi (PostgreSQL): Update accordingly. Christopher Baines 2020-10-20services: databases: Deprecate the postgresql-service procedure....Using the service type directly is a better approach, making it easier to configure the service. * gnu/services/databases.scm (postgresql-service): Deprecate this procedure. * doc/guix.texi (PostgreSQL): Update the documentation for the use of (service postgresql-service-type). Christopher Baines 2020-08-01services: postgresql: Provide postgresql commands....* gnu/services/databases.scm (postgresql-service-type): Extend profile-service-type to provide postgresql commands. Pierre Neidhardt 2020-01-17gnu: services: Allow extra content in mysql configuration....* gnu/services/databases.scm (<mysql-configuration>): New field. (mysql-configuration-file): Use it. Alex Sassmannshausen 2020-01-14gnu: services: Fix mysql service activation....This change is necessary after the split of mariadb outputs. * gnu/services/databases.scm (%mysql-activation): Use mysql:lib in mariadb-specific part. Julien Lepiller 2019-07-02gnu: postgres service: More secure default permissions....This changes to 'peer' authentication for local socket connections, and password-based authentication for local network connections. * gnu/services/databases.scm (%default-postgres-hba): Change authentication method. Signed-off-by: Ludovic Courtès <ludo@gnu.org> Robert Vollmert 2018-10-04gnu: postgresql: Add extension-packages....* gnu/services/databases.scm (postgresql-configuration): Add extension-packages. (postgresql-shepherd-service): New key #:extension-packages. * doc/guix.texi (Database Services): Document it. Julien Lepiller 2018-08-13services: postgresql: Get the Shepherd to respawn PostgreSQL....* gnu/services/databases.scm (postgresql-shepherd-service): Change 'start' to return the PID. Clément Lassieur 2018-03-17services: databases: Change quote' to single-quote....In the postgresql-config-file gexp compiler. * gnu/services/databases.scm (postgresql-config-file-compiler): Change quote' to single-quote. Christopher Baines 2018-03-10services: databases: Add postgresql-configuration record exports....* gnu/services/databases.scm: Export the record type, and all the field accessors. Christopher Baines 2018-03-10services: Rework the PostgreSQL config file to use a record type....For the default config file representation. This makes it possible to more easily change the configuration file, and have dynamic content. * gnu/services/databases.scm (<postgresql-config-file>): New record type. (%default-postgres-config): Remove this, it's been replaced by the configuration file. (<postgresql-configuration>): Alter the default for the config file field. (postgresql-service): Alter the default value for the config-file parameter. Christopher Baines 2018-03-03services: redis: Add a default-value to the redis-service-type....* gnu/packages/databases.scm (redis-service-type)[default-value]: Set to (redis-configuration). Christopher Baines 2018-03-03services: mysql: Add a default-value to the mysql-service-type....* gnu/services/databases.scm (mysql-service-type)[default-value]: Set to (mysql-configuration). Christopher Baines 2018-03-03services: postgresql: Add a default-value to the postgresql-service-type....* gnu/packages/databases.scm (<postgresql-configuration>) [config-file,data-directory]: Add default. (postgresql-service-type)[default-value]: Set to (postgresql-configuration). Christopher Baines 2018-01-25services: postgresql: Use pg_ctl to start and stop postgres....Fixes <https://bugs.gnu.org/29992>. * gnu/services/databases.scm (postgresql-shepherd-service): Replace make-forkexec-constructor and make-kill-destructor with pg_ctl. Clément Lassieur 2017-10-06services: Add MongoDB....* gnu/services/databases.scm (%default-mongodb-configuration-file, %mongodb-accounts, mongodb-service-type): New variables. (<mongodb-configuration>): New record type. (mongodb-activation, mongodb-shepherd-service): New procedures. * gnu/tests/databases.scm (%test-mongodb): New variable. * doc/guix.texi (Database Services): Add MongoDB documentation. Christopher Baines 2017-08-15gnu: Fix memcached service startup....Memcached changes to the memcached user from root before writing the PID file. This means that it must be able to write the PID file as the memcached user. To make this work, create the /var/run/memcached directory when the service starts, make it owned by memcached, and change memcached to write the PID file to /var/run/memcached/pid. This wasn't picked up by the system test as the "service running" part was too permissive, and only failed on an error. Instead, test the response from calling start-service and check that the PID is a number. * gnu/services/databases.scm (memcached-activation): New variable. (memcached-shepherd-service): Change PID file location. (memcached-service-type): Extend the activation-service-type. * gnu/tests/databases.scm (run-memcached-test)[test]: Change the "service running" test to check the response from the shepherd. Christopher Baines 2017-07-30services: Add memcached....* gnu/services/databases.scm (memcached-service-type, %memcached-accounts): New variables. (<memcached-configuration>): New record type. (memcached-service-type): New procedures. * gnu/tests/databases.scm: New file. * doc/guix.texi (Database Services): Document the new memcached service. * gnu/local.mk (GNU_SYSTEM_MODULES): Add entry for tests/databases.scm. Christopher Baines 2017-01-12services: Add 'redis-service-type'....* gnu/services/database.scm (<redis-configuration>): New record type. (%redis-accounts, redis-service-type): New variables. (default-redis.conf, redis-activation, redis-shepherd-service): New procedures. * doc/guix.texi (Database Services): Document the new redis service. Signed-off-by: Ludovic Courtès <ludo@gnu.org> Christopher Baines 2016-12-15services: postgresql: Add locale to configuration...* gnu/services/databases.scm (<postgresql-configuration>): Add locale field. (postgresql-shepherd-service): Pass locale to initdb. (postgresql-service): Add locale default. Signed-off-by: Ludovic Courtès <ludo@gnu.org> Christopher Baines 2016-12-15services: postgresql: Add port to configuration...* gnu/services/databases.scm (<postgresql-configuration>): Add port field. (postgresql-shepherd-service): Pass port to postgres. (postgresql-service): Add port default. Signed-off-by: Ludovic Courtès <ludo@gnu.org> Christopher Baines 2016-12-14services: mysql: Add port to configuration...* gnu/services/databases.scm (<mysql-configuration>): Add port field. (mysql-configuration-file): Use the port field when creating the configuration file. * doc/guix.texi (Database Services): Document it. Co-authored-by: Ludovic Courtès <ludo@gnu.org> Christopher Baines