tests/status.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 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 '("foo.drv"))
  40          (downloading (list (download "bar" "http://example.org/bar"
  41                                       #:size 500
  42                                       #:start 'now))))
  43         (build-status
  44          (building '("foo.drv"))
  45          (downloading (list (download "bar" "http://example.org/bar"
  46                                       #:size 500
  47                                       #:transferred 42
  48                                       #:start 'now))))
  49         (build-status
  50          (builds-completed '("foo.drv"))
  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\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 '("foo.drv"))
  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 '("foo.drv"))
  90          (downloads-completed (list (download "baz" "http://example.org/baz"
  91                                               #:size 500
  92                                               #:transferred 500
  93                                               #:start 'now
  94                                               #:end 'now)
  95                                     (download "bar" "http://example.org/bar"
  96                                               #:size 999
  97                                               #:transferred 999
  98                                               #:start 'now
  99                                               #:end 'now)))))
 100   ;; Below we omit 'substituter-started' events and the like.
 101   (let-values (((port get-status)
 102                 (build-event-output-port (lambda (event status)
 103                                            (compute-status event status
 104                                                            #:current-time
 105                                                            (const 'now))))))
 106     (display "@ build-started foo.drv\n" port)
 107     (display "@ download-started bar http://example.org/bar 999\n" port)
 108     (display "various\nthings\nget\nwritten\n" port)
 109     (display "@ download-progress baz http://example.org/baz 500 42\n"
 110              port)
 111     (let ((first (get-status)))
 112       (display "@ build-succeeded foo.drv\n" port)
 113       (display "@ download-succeeded bar http://example.org/bar 999\n" port)
 114       (display "Almost done!\n" port)
 115       (display "@ substituter-succeeded baz\n" port)
 116       (list first (get-status)))))
 117
 118 (test-equal "build-output-port, UTF-8"
 119   '((build-log #f "lambda is λ!\n"))
 120   (let-values (((port get-status) (build-event-output-port cons '()))
 121                ((bv)              (string->utf8 "lambda is λ!\n")))
 122     (put-bytevector port bv)
 123     (force-output port)
 124     (get-status)))
 125
 126 (test-equal "current-build-output-port, UTF-8 + garbage"
 127   ;; What about a mixture of UTF-8 + garbage?
 128   '((build-log #f "garbage: �lambda: λ\n"))
 129   (let-values (((port get-status) (build-event-output-port cons '())))
 130     (display "garbage: " port)
 131     (put-bytevector port #vu8(128))
 132     (put-bytevector port (string->utf8 "lambda: λ\n"))
 133     (force-output port)
 134     (get-status)))
 135
 136 (test-equal "compute-status, multiplexed build output"
 137   (list (build-status
 138          (building '("foo.drv"))
 139          (downloading (list (download "bar" "http://example.org/bar"
 140                                       #:size 999
 141                                       #:start 'now))))
 142         (build-status
 143          (building '("foo.drv"))
 144          (downloading (list (download "bar" "http://example.org/bar"
 145                                       #:size 999
 146                                       #:transferred 42
 147                                       #:start 'now))))
 148         (build-status
 149          ;; XXX: Should "bar.drv" be present twice?
 150          (builds-completed '("bar.drv" "foo.drv"))
 151          (downloads-completed (list (download "bar" "http://example.org/bar"
 152                                               #:size 999
 153                                               #:transferred 999
 154                                               #:start 'now
 155                                               #:end 'now)))))
 156   (let-values (((port get-status)
 157                 (build-event-output-port (lambda (event status)
 158                                            (compute-status event status
 159                                                            #:current-time
 160                                                            (const 'now)
 161                                                            #:derivation-path->output-path
 162                                                            (match-lambda
 163                                                              ("bar.drv" "bar")))))))
 164     (display "@ build-started foo.drv 121\n" port)
 165     (display "@ build-started bar.drv 144\n" port)
 166     (display "@ build-log 121 6\nHello!" port)
 167     (display "@ build-log 144 50
 168 @ download-started bar http://example.org/bar 999\n" port)
 169     (let ((first (get-status)))
 170       (display "@ build-log 121 30\n@ build-started FAKE!.drv 555\n")
 171       (display "@ build-log 144 54
 172 @ download-progress bar http://example.org/bar 999 42\n"
 173                port)
 174       (let ((second (get-status)))
 175         (display "@ download-succeeded bar http://example.org/bar 999\n" port)
 176         (display "@ build-succeeded foo.drv\n" port)
 177         (display "@ build-succeeded bar.drv\n" port)
 178         (list first second (get-status))))))
 179
 180 (test-end "status")