tests/status.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019 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-11)
  23   #:use-module (srfi srfi-64)
  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-values (((port get-status)
  33                 (build-event-output-port compute-status)))
  34     (display "foo\nbar\n\baz\n" port)
  35     (get-status)))
  36
  37 (test-equal "compute-status, builds + substitutes"
  38   (list (build-status
  39          (building (list (build "foo.drv" "x86_64-linux")))
  40          (downloading (list (download "bar" "http://example.org/bar"
  41                                       #:size 500
  42                                       #:start 'now))))
  43         (build-status
  44          (building (list (build "foo.drv" "x86_64-linux")))
  45          (downloading (list (download "bar" "http://example.org/bar"
  46                                       #:size 500
  47                                       #:transferred 42
  48                                       #:start 'now))))
  49         (build-status
  50          (builds-completed (list (build "foo.drv" "x86_64-linux")))
  51          (downloads-completed (list (download "bar" "http://example.org/bar"
  52                                               #:size 500
  53                                               #:transferred 500
  54                                               #:start 'now
  55                                               #:end 'now)))))
  56   (let-values (((port get-status)
  57                 (build-event-output-port (lambda (event status)
  58                                            (compute-status event status
  59                                                            #:current-time
  60                                                            (const 'now))))))
  61     (display "@ build-started foo.drv - x86_64-linux \n" port)
  62     (display "@ substituter-started bar\n" port)
  63     (display "@ download-started bar http://example.org/bar 500\n" port)
  64     (display "various\nthings\nget\nwritten\n" port)
  65     (let ((first (get-status)))
  66       (display "@ download-progress bar http://example.org/bar 500 42\n"
  67                port)
  68       (let ((second (get-status)))
  69         (display "@ download-progress bar http://example.org/bar 500 84\n"
  70                  port)
  71         (display "@ build-succeeded foo.drv\n" port)
  72         (display "@ download-succeeded bar http://example.org/bar 500\n" port)
  73         (display "Almost done!\n" port)
  74         (display "@ substituter-succeeded bar\n" port)
  75         (list first second (get-status))))))
  76
  77 (test-equal "compute-status, missing events"
  78   (list (build-status
  79          (building (list (build "foo.drv" "x86_64-linux"
  80                                 #:log-file "foo.log")))
  81          (downloading (list (download "baz" "http://example.org/baz"
  82                                       #:size 500
  83                                       #:transferred 42
  84                                       #:start 'now)
  85                             (download "bar" "http://example.org/bar"
  86                                       #:size 999
  87                                       #:transferred 0
  88                                       #:start 'now))))
  89         (build-status
  90          (builds-completed (list (build "foo.drv" "x86_64-linux"
  91                                         #:log-file "foo.log")))
  92          (downloads-completed (list (download "baz" "http://example.org/baz"
  93                                               #:size 500
  94                                               #:transferred 500
  95                                               #:start 'now
  96                                               #:end 'now)
  97                                     (download "bar" "http://example.org/bar"
  98                                               #:size 999
  99                                               #:transferred 999
 100                                               #:start 'now
 101                                               #:end 'now)))))
 102   ;; Below we omit 'substituter-started' events and the like.
 103   (let-values (((port get-status)
 104                 (build-event-output-port (lambda (event status)
 105                                            (compute-status event status
 106                                                            #:current-time
 107                                                            (const 'now))))))
 108     (display "@ build-started foo.drv - x86_64-linux foo.log\n" port)
 109     (display "@ download-started bar http://example.org/bar 999\n" port)
 110     (display "various\nthings\nget\nwritten\n" port)
 111     (display "@ download-progress baz http://example.org/baz 500 42\n"
 112              port)
 113     (let ((first (get-status)))
 114       (display "@ build-succeeded foo.drv\n" port)
 115       (display "@ download-succeeded bar http://example.org/bar 999\n" port)
 116       (display "Almost done!\n" port)
 117       (display "@ substituter-succeeded baz\n" port)
 118       (list first (get-status)))))
 119
 120 (test-equal "build-output-port, UTF-8"
 121   '((build-log #f "lambda is λ!\n"))
 122   (let-values (((port get-status) (build-event-output-port cons '()))
 123                ((bv)              (string->utf8 "lambda is λ!\n")))
 124     (put-bytevector port bv)
 125     (force-output port)
 126     (get-status)))
 127
 128 (test-equal "current-build-output-port, UTF-8 + garbage"
 129   ;; What about a mixture of UTF-8 + garbage?
 130   (let ((replacement "�"))
 131     `((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n"))))
 132   (let-values (((port get-status) (build-event-output-port cons '())))
 133     (display "garbage: " port)
 134     (put-bytevector port #vu8(128))
 135     (put-bytevector port (string->utf8 "lambda: λ\n"))
 136     (force-output port)
 137     (get-status)))
 138
 139 (test-equal "compute-status, multiplexed build output"
 140   (list (build-status
 141          (building (list (build "foo.drv" "x86_64-linux" #:id 121)))
 142          (downloading (list (download "bar" "http://example.org/bar"
 143                                       #:size 999
 144                                       #:start 'now))))
 145         (build-status
 146          (building (list (build "foo.drv" "x86_64-linux" #:id 121)))
 147          (downloading (list (download "bar" "http://example.org/bar"
 148                                       #:size 999
 149                                       #:transferred 42
 150                                       #:start 'now))))
 151         (build-status
 152          ;; "bar" is now only listed as a download.
 153          (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121)))
 154          (downloads-completed (list (download "bar" "http://example.org/bar"
 155                                               #:size 999
 156                                               #:transferred 999
 157                                               #:start 'now
 158                                               #:end 'now)))))
 159   (let-values (((port get-status)
 160                 (build-event-output-port (lambda (event status)
 161                                            (compute-status event status
 162                                                            #:current-time
 163                                                            (const 'now)
 164                                                            #:derivation-path->output-path
 165                                                            (match-lambda
 166                                                              ("bar.drv" "bar")))))))
 167     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
 168     (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port)
 169     (display "@ build-log 121 6\nHello!" port)
 170     (display "@ build-log 144 50
 171 @ download-started bar http://example.org/bar 999\n" port)
 172     (let ((first (get-status)))
 173       (display "@ build-log 121 30\n@ build-started FAKE!.drv 555\n")
 174       (display "@ build-log 144 54
 175 @ download-progress bar http://example.org/bar 999 42\n"
 176                port)
 177       (let ((second (get-status)))
 178         (display "@ download-succeeded bar http://example.org/bar 999\n" port)
 179         (display "@ build-succeeded foo.drv\n" port)
 180         (display "@ build-succeeded bar.drv\n" port)
 181         (list first second (get-status))))))
 182
 183 (test-equal "compute-status, build completion"
 184   (list (build-status
 185          (building (list (build "foo.drv" "x86_64-linux" #:id 121))))
 186         (build-status
 187          (building (list (build "foo.drv" "x86_64-linux" #:id 121
 188                                 #:completion 0.))))
 189         (build-status
 190          (building (list (build "foo.drv" "x86_64-linux" #:id 121
 191                                 #:completion 50.))))
 192         (build-status
 193          (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121
 194                                         #:completion 100.)))))
 195   (let-values (((port get-status)
 196                 (build-event-output-port (lambda (event status)
 197                                            (compute-status event status
 198                                                            #:current-time
 199                                                            (const 'now))))))
 200     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
 201     (display "@ build-log 121 6\nHello!" port)
 202     (let ((first (get-status)))
 203       (display "@ build-log 121 20\n[ 0/100] building X\n" port)
 204       (display "@ build-log 121 6\nHello!" port)
 205       (let ((second (get-status)))
 206         (display "@ build-log 121 20\n[50/100] building Y\n" port)
 207         (display "@ build-log 121 6\nHello!" port)
 208         (let ((third (get-status)))
 209           (display "@ build-log 121 21\n[100/100] building Z\n" port)
 210           (display "@ build-log 121 6\nHello!" port)
 211           (display "@ build-succeeded foo.drv\n" port)
 212           (list first second third (get-status)))))))
 213
 214 (test-equal "compute-status, build phase"
 215   (list (build-status
 216          (building (list (build "foo.drv" "x86_64-linux" #:id 121
 217                                 #:phase 'configure))))
 218         (build-status
 219          (building (list (build "foo.drv" "x86_64-linux" #:id 121
 220                                 #:phase 'configure
 221                                 #:completion 50.))))
 222         (build-status
 223          (building (list (build "foo.drv" "x86_64-linux" #:id 121
 224                                 #:phase 'install))))
 225         (build-status
 226          (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121
 227                                         #:phase 'install)))))
 228   (let-values (((port get-status)
 229                 (build-event-output-port (lambda (event status)
 230                                            (compute-status event status
 231                                                            #:current-time
 232                                                            (const 'now))))))
 233     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
 234     (display "@ build-log 121 27\nstarting phase `configure'\n" port)
 235     (display "@ build-log 121 6\nabcde!" port)
 236     (let ((first (get-status)))
 237       (display "@ build-log 121 20\n[50/100] building Y\n" port)
 238       (display "@ build-log 121 6\nfghik!" port)
 239       (let ((second (get-status)))
 240         (display "@ build-log 121 21\n[100/100] building Z\n" port)
 241         (display "@ build-log 121 25\nstarting phase `install'\n" port)
 242         (display "@ build-log 121 6\nlmnop!" port)
 243         (let ((third (get-status)))
 244           (display "@ build-succeeded foo.drv\n" port)
 245           (list first second third (get-status)))))))
 246
 247 (test-end "status")