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
  27 (test-begin "status")
  28
  29 (test-equal "compute-status, no-op"
  30   (build-status)
  31   (let-values (((port get-status)
  32                 (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 '("foo.drv"))
  39          (downloading (list (download "bar" "http://example.org/bar"
  40                                       #:size 500
  41                                       #:start 'now))))
  42         (build-status
  43          (building '("foo.drv"))
  44          (downloading (list (download "bar" "http://example.org/bar"
  45                                       #:size 500
  46                                       #:transferred 42
  47                                       #:start 'now))))
  48         (build-status
  49          (builds-completed '("foo.drv"))
  50          (downloads-completed (list (download "bar" "http://example.org/bar"
  51                                               #:size 500
  52                                               #:transferred 500
  53                                               #:start 'now
  54                                               #:end 'now)))))
  55   (let-values (((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\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 '("foo.drv"))
  79          (downloading (list (download "baz" "http://example.org/baz"
  80                                       #:size 500
  81                                       #:transferred 42
  82                                       #:start 'now)
  83                             (download "bar" "http://example.org/bar"
  84                                       #:size 999
  85                                       #:transferred 0
  86                                       #:start 'now))))
  87         (build-status
  88          (builds-completed '("foo.drv"))
  89          (downloads-completed (list (download "baz" "http://example.org/baz"
  90                                               #:size 500
  91                                               #:transferred 500
  92                                               #:start 'now
  93                                               #:end 'now)
  94                                     (download "bar" "http://example.org/bar"
  95                                               #:size 999
  96                                               #:transferred 999
  97                                               #:start 'now
  98                                               #:end 'now)))))
  99   ;; Below we omit 'substituter-started' events and the like.
 100   (let-values (((port get-status)
 101                 (build-event-output-port (lambda (event status)
 102                                            (compute-status event status
 103                                                            #:current-time
 104                                                            (const 'now))))))
 105     (display "@ build-started foo.drv\n" port)
 106     (display "@ download-started bar http://example.org/bar 999\n" port)
 107     (display "various\nthings\nget\nwritten\n" port)
 108     (display "@ download-progress baz http://example.org/baz 500 42\n"
 109              port)
 110     (let ((first (get-status)))
 111       (display "@ build-succeeded foo.drv\n" port)
 112       (display "@ download-succeeded bar http://example.org/bar 999\n" port)
 113       (display "Almost done!\n" port)
 114       (display "@ substituter-succeeded baz\n" port)
 115       (list first (get-status)))))
 116
 117 (test-equal "build-output-port, UTF-8"
 118   '((build-log "lambda is λ!\n"))
 119   (let-values (((port get-status) (build-event-output-port cons '()))
 120                ((bv)              (string->utf8 "lambda is λ!\n")))
 121     (put-bytevector port bv)
 122     (force-output port)
 123     (get-status)))
 124
 125 (test-equal "current-build-output-port, UTF-8 + garbage"
 126   ;; What about a mixture of UTF-8 + garbage?
 127   '((build-log "garbage: �lambda: λ\n"))
 128   (let-values (((port get-status) (build-event-output-port cons '())))
 129     (display "garbage: " port)
 130     (put-bytevector port #vu8(128))
 131     (put-bytevector port (string->utf8 "lambda: λ\n"))
 132     (force-output port)
 133     (get-status)))
 134
 135 (test-end "status")