[jackhill/guix/guix.git] / tests / status.scm

;;; 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")
Commit	Line	Data
dc0f74e5	1	;;; GNU Guix --- Functional package management for GNU
c31605b5	2	;;; Copyright © 2018, 2019, 2022 Ludovic Courtès <ludo@gnu.org>
dc0f74e5 LC	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)
fe17037b	22	#:use-module (srfi srfi-64)
c31605b5	23	#:use-module (srfi srfi-71)
fe17037b	24	#:use-module (rnrs bytevectors)
f9a8fce1 LC	25	#:use-module (rnrs io ports)
f9a8fce1 LC	26	#:use-module (ice-9 match))
dc0f74e5 LC	27
	28	(test-begin "status")
	29
	30	(test-equal "compute-status, no-op"
	31	(build-status)
c31605b5	32	(let ((port get-status (build-event-output-port compute-status)))
dc0f74e5 LC	33	(display "foo\nbar\n\baz\n" port)
	34	(get-status)))
	35
	36	(test-equal "compute-status, builds + substitutes"
	37	(list (build-status
976ef2d9	38	(building (list (build "foo.drv" "x86_64-linux")))
dc0f74e5 LC	39	(downloading (list (download "bar" "http://example.org/bar"
	40	#:size 500
	41	#:start 'now))))
	42	(build-status
976ef2d9	43	(building (list (build "foo.drv" "x86_64-linux")))
dc0f74e5 LC	44	(downloading (list (download "bar" "http://example.org/bar"
	45	#:size 500
	46	#:transferred 42
	47	#:start 'now))))
	48	(build-status
976ef2d9	49	(builds-completed (list (build "foo.drv" "x86_64-linux")))
dc0f74e5 LC	50	(downloads-completed (list (download "bar" "http://example.org/bar"
	51	#:size 500
	52	#:transferred 500
	53	#:start 'now
	54	#:end 'now)))))
c31605b5 LC	55	(let ((port get-status
	56	(build-event-output-port (lambda (event status)
	57	(compute-status event status
	58	#:current-time
	59	(const 'now))))))
976ef2d9	60	(display "@ build-started foo.drv - x86_64-linux \n" port)
dc0f74e5 LC	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
976ef2d9 LC	78	(building (list (build "foo.drv" "x86_64-linux"
976ef2d9 LC	79	#:log-file "foo.log")))
dc0f74e5 LC	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
976ef2d9 LC	89	(builds-completed (list (build "foo.drv" "x86_64-linux"
976ef2d9 LC	90	#:log-file "foo.log")))
dc0f74e5 LC	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.
c31605b5 LC	102	(let ((port get-status
	103	(build-event-output-port (lambda (event status)
	104	(compute-status event status
	105	#:current-time
	106	(const 'now))))))
976ef2d9	107	(display "@ build-started foo.drv - x86_64-linux foo.log\n" port)
dc0f74e5 LC	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
fe17037b	119	(test-equal "build-output-port, UTF-8"
f9a8fce1	120	'((build-log #f "lambda is λ!\n"))
c31605b5 LC	121	(let ((port get-status (build-event-output-port cons '()))
c31605b5 LC	122	(bv (string->utf8 "lambda is λ!\n")))
fe17037b LC	123	(put-bytevector port bv)
	124	(force-output port)
	125	(get-status)))
	126
f99f00fc LC	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
fe17037b LC	141	(test-equal "current-build-output-port, UTF-8 + garbage"
fe17037b LC	142	;; What about a mixture of UTF-8 + garbage?
a65177a6	143	(let ((replacement "�"))
278f86a4	144	`((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n"))))
c31605b5	145	(let ((port get-status (build-event-output-port cons '())))
fe17037b LC	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
f9a8fce1 LC	152	(test-equal "compute-status, multiplexed build output"
f9a8fce1 LC	153	(list (build-status
976ef2d9	154	(building (list (build "foo.drv" "x86_64-linux" #:id 121)))
f9a8fce1 LC	155	(downloading (list (download "bar" "http://example.org/bar"
	156	#:size 999
	157	#:start 'now))))
	158	(build-status
976ef2d9	159	(building (list (build "foo.drv" "x86_64-linux" #:id 121)))
f9a8fce1 LC	160	(downloading (list (download "bar" "http://example.org/bar"
	161	#:size 999
	162	#:transferred 42
	163	#:start 'now))))
	164	(build-status
976ef2d9 LC	165	;; "bar" is now only listed as a download.
976ef2d9 LC	166	(builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121)))
f9a8fce1 LC	167	(downloads-completed (list (download "bar" "http://example.org/bar"
	168	#:size 999
	169	#:transferred 999
	170	#:start 'now
	171	#:end 'now)))))
c31605b5 LC	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")))))))
976ef2d9 LC	180	(display "@ build-started foo.drv - x86_64-linux 121\n" port)
976ef2d9 LC	181	(display "@ build-started bar.drv - armhf-linux bar.log 144\n" port)
f9a8fce1 LC	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
73a8681a LC	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.)))))
c31605b5 LC	208	(let ((port get-status
	209	(build-event-output-port (lambda (event status)
	210	(compute-status event status
	211	#:current-time
	212	(const 'now))))))
73a8681a LC	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
ba514b60 LC	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)))))
c31605b5 LC	241	(let ((port get-status
	242	(build-event-output-port (lambda (event status)
	243	(compute-status event status
	244	#:current-time
	245	(const 'now))))))
ba514b60 LC	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
dc0f74e5	260	(test-end "status")