tests/status.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019, 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (test-status)
  20   #:use-module (guix status)
  21   #:use-module (srfi srfi-1)
  22   #:use-module (srfi srfi-64)
  23   #:use-module (srfi srfi-71)
  24   #:use-module (rnrs bytevectors)
  25   #:use-module (rnrs io ports)
  26   #:use-module (ice-9 match))
  27
  28 (test-begin "status")
  29
  30 (test-equal "compute-status, no-op"
  31   (build-status)
  32   (let ((port get-status (build-event-output-port compute-status)))
  33     (display "foo\nbar\n\baz\n" port)
  34     (get-status)))
  35
  36 (test-equal "compute-status, builds + substitutes"
  37   (list (build-status
  38          (building (list (build "foo.drv" "x86_64-linux")))
  39          (downloading (list (download "bar" "http://example.org/bar"
  40                                       #:size 500
  41                                       #:start 'now))))
  42         (build-status
  43          (building (list (build "foo.drv" "x86_64-linux")))
  44          (downloading (list (download "bar" "http://example.org/bar"
  45                                       #:size 500
  46                                       #:transferred 42
  47                                       #:start 'now))))
  48         (build-status
  49          (builds-completed (list (build "foo.drv" "x86_64-linux")))
  50          (downloads-completed (list (download "bar" "http://example.org/bar"
  51                                               #:size 500
  52                                               #:transferred 500
  53                                               #:start 'now
  54                                               #:end 'now)))))
  55   (let ((port get-status
  56               (build-event-output-port (lambda (event status)
  57                                          (compute-status event status
  58                                                          #:current-time
  59                                                          (const 'now))))))
  60     (display "@ build-started foo.drv - x86_64-linux \n" port)
  61     (display "@ substituter-started bar\n" port)
  62     (display "@ download-started bar http://example.org/bar 500\n" port)
  63     (display "various\nthings\nget\nwritten\n" port)
  64     (let ((first (get-status)))
  65       (display "@ download-progress bar http://example.org/bar 500 42\n"
  66                port)
  67       (let ((second (get-status)))
  68         (display "@ download-progress bar http://example.org/bar 500 84\n"
  69                  port)
  70         (display "@ build-succeeded foo.drv\n" port)
  71         (display "@ download-succeeded bar http://example.org/bar 500\n" port)
  72         (display "Almost done!\n" port)
  73         (display "@ substituter-succeeded bar\n" port)
  74         (list first second (get-status))))))
  75
  76 (test-equal "compute-status, missing events"
  77   (list (build-status
  78          (building (list (build "foo.drv" "x86_64-linux"
  79                                 #:log-file "foo.log")))
  80          (downloading (list (download "baz" "http://example.org/baz"
  81                                       #:size 500
  82                                       #:transferred 42
  83                                       #:start 'now)
  84                             (download "bar" "http://example.org/bar"
  85                                       #:size 999
  86                                       #:transferred 0
  87                                       #:start 'now))))
  88         (build-status
  89          (builds-completed (list (build "foo.drv" "x86_64-linux"
  90                                         #:log-file "foo.log")))
  91          (downloads-completed (list (download "baz" "http://example.org/baz"
  92                                               #:size 500
  93                                               #:transferred 500
  94                                               #:start 'now
  95                                               #:end 'now)
  96                                     (download "bar" "http://example.org/bar"
  97                                               #:size 999
  98                                               #:transferred 999
  99                                               #:start 'now
 100                                               #:end 'now)))))
 101   ;; Below we omit 'substituter-started' events and the like.
 102   (let ((port get-status
 103               (build-event-output-port (lambda (event status)
 104                                          (compute-status event status
 105                                                          #:current-time
 106                                                          (const 'now))))))
 107     (display "@ build-started foo.drv - x86_64-linux foo.log\n" port)
 108     (display "@ download-started bar http://example.org/bar 999\n" port)
 109     (display "various\nthings\nget\nwritten\n" port)
 110     (display "@ download-progress baz http://example.org/baz 500 42\n"
 111              port)
 112     (let ((first (get-status)))
 113       (display "@ build-succeeded foo.drv\n" port)
 114       (display "@ download-succeeded bar http://example.org/bar 999\n" port)
 115       (display "Almost done!\n" port)
 116       (display "@ substituter-succeeded baz\n" port)
 117       (list first (get-status)))))
 118
 119 (test-equal "build-output-port, UTF-8"
 120   '((build-log #f "lambda is λ!\n"))
 121   (let ((port get-status (build-event-output-port cons '()))
 122         (bv              (string->utf8 "lambda is λ!\n")))
 123     (put-bytevector port bv)
 124     (force-output port)
 125     (get-status)))
 126
 127 (test-equal "build-output-port, daemon messages with LF"
 128   '((build-log #f "updating substitutes... 0%\r")
 129     (build-log #f "updating substitutes... 50%\r")
 130     (build-log #f "updating substitutes... 100%\r"))
 131   (let ((port get-status (build-event-output-port cons '())))
 132     (for-each (lambda (suffix)
 133                 (let ((bv (string->utf8
 134                            (string-append "updating substitutes... "
 135                                           suffix "\r"))))
 136                   (put-bytevector port bv)
 137                   (force-output port)))
 138               '("0%" "50%" "100%"))
 139     (reverse (get-status))))
 140
 141 (test-equal "current-build-output-port, UTF-8 + garbage"
 142   ;; What about a mixture of UTF-8 + garbage?
 143   (let ((replacement "�"))
 144     `((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n"))))
 145   (let ((port get-status (build-event-output-port cons '())))
 146     (display "garbage: " port)
 147     (put-bytevector port #vu8(128))
 148     (put-bytevector port (string->utf8 "lambda: λ\n"))
 149     (force-output port)
 150     (get-status)))
 151
 152 (test-equal "compute-status, multiplexed build output"
 153   (list (build-status
 154          (building (list (build "foo.drv" "x86_64-linux" #:id 121)))
 155          (downloading (list (download "bar" "http://example.org/bar"
 156                                       #:size 999
 157                                       #:start 'now))))
 158         (build-status
 159          (building (list (build "foo.drv" "x86_64-linux" #:id 121)))
 160          (downloading (list (download "bar" "http://example.org/bar"
 161                                       #:size 999
 162                                       #:transferred 42
 163                                       #:start 'now))))
 164         (build-status
 165          ;; "bar" is now only listed as a download.
 166          (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121)))
 167          (downloads-completed (list (download "bar" "http://example.org/bar"
 168                                               #:size 999
 169                                               #:transferred 999
 170                                               #:start 'now
 171                                               #:end 'now)))))
 172   (let ((port get-status
 173               (build-event-output-port (lambda (event status)
 174                                          (compute-status event status
 175                                                          #:current-time
 176                                                          (const 'now)
 177                                                          #:derivation-path->output-path
 178                                                          (match-lambda
 179                                                            ("bar.drv" "bar")))))))
 180     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
 181     (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port)
 182     (display "@ build-log 121 6\nHello!" port)
 183     (display "@ build-log 144 50
 184 @ download-started bar http://example.org/bar 999\n" port)
 185     (let ((first (get-status)))
 186       (display "@ build-log 121 30\n@ build-started FAKE!.drv 555\n")
 187       (display "@ build-log 144 54
 188 @ download-progress bar http://example.org/bar 999 42\n"
 189                port)
 190       (let ((second (get-status)))
 191         (display "@ download-succeeded bar http://example.org/bar 999\n" port)
 192         (display "@ build-succeeded foo.drv\n" port)
 193         (display "@ build-succeeded bar.drv\n" port)
 194         (list first second (get-status))))))
 195
 196 (test-equal "compute-status, build completion"
 197   (list (build-status
 198          (building (list (build "foo.drv" "x86_64-linux" #:id 121))))
 199         (build-status
 200          (building (list (build "foo.drv" "x86_64-linux" #:id 121
 201                                 #:completion 0.))))
 202         (build-status
 203          (building (list (build "foo.drv" "x86_64-linux" #:id 121
 204                                 #:completion 50.))))
 205         (build-status
 206          (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121
 207                                         #:completion 100.)))))
 208   (let ((port get-status
 209               (build-event-output-port (lambda (event status)
 210                                          (compute-status event status
 211                                                          #:current-time
 212                                                          (const 'now))))))
 213     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
 214     (display "@ build-log 121 6\nHello!" port)
 215     (let ((first (get-status)))
 216       (display "@ build-log 121 20\n[ 0/100] building X\n" port)
 217       (display "@ build-log 121 6\nHello!" port)
 218       (let ((second (get-status)))
 219         (display "@ build-log 121 20\n[50/100] building Y\n" port)
 220         (display "@ build-log 121 6\nHello!" port)
 221         (let ((third (get-status)))
 222           (display "@ build-log 121 21\n[100/100] building Z\n" port)
 223           (display "@ build-log 121 6\nHello!" port)
 224           (display "@ build-succeeded foo.drv\n" port)
 225           (list first second third (get-status)))))))
 226
 227 (test-equal "compute-status, build phase"
 228   (list (build-status
 229          (building (list (build "foo.drv" "x86_64-linux" #:id 121
 230                                 #:phase 'configure))))
 231         (build-status
 232          (building (list (build "foo.drv" "x86_64-linux" #:id 121
 233                                 #:phase 'configure
 234                                 #:completion 50.))))
 235         (build-status
 236          (building (list (build "foo.drv" "x86_64-linux" #:id 121
 237                                 #:phase 'install))))
 238         (build-status
 239          (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121
 240                                         #:phase 'install)))))
 241   (let ((port get-status
 242               (build-event-output-port (lambda (event status)
 243                                          (compute-status event status
 244                                                          #:current-time
 245                                                          (const 'now))))))
 246     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
 247     (display "@ build-log 121 27\nstarting phase `configure'\n" port)
 248     (display "@ build-log 121 6\nabcde!" port)
 249     (let ((first (get-status)))
 250       (display "@ build-log 121 20\n[50/100] building Y\n" port)
 251       (display "@ build-log 121 6\nfghik!" port)
 252       (let ((second (get-status)))
 253         (display "@ build-log 121 21\n[100/100] building Z\n" port)
 254         (display "@ build-log 121 25\nstarting phase `install'\n" port)
 255         (display "@ build-log 121 6\nlmnop!" port)
 256         (let ((third (get-status)))
 257           (display "@ build-succeeded foo.drv\n" port)
 258           (list first second third (get-status)))))))
 259
 260 (test-end "status")