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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 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-11)
  #:use-module (srfi srfi-64)
  #: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-values (((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-values (((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-values (((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-values (((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 "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-values (((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-values (((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-values (((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-values (((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
a65177a6	2	;;; Copyright © 2018, 2019 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)
	22	#:use-module (srfi srfi-11)
fe17037b LC	23	#:use-module (srfi srfi-64)
fe17037b LC	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)
	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
976ef2d9	39	(building (list (build "foo.drv" "x86_64-linux")))
dc0f74e5 LC	40	(downloading (list (download "bar" "http://example.org/bar"
	41	#:size 500
	42	#:start 'now))))
	43	(build-status
976ef2d9	44	(building (list (build "foo.drv" "x86_64-linux")))
dc0f74e5 LC	45	(downloading (list (download "bar" "http://example.org/bar"
	46	#:size 500
	47	#:transferred 42
	48	#:start 'now))))
	49	(build-status
976ef2d9	50	(builds-completed (list (build "foo.drv" "x86_64-linux")))
dc0f74e5 LC	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))))))
976ef2d9	61	(display "@ build-started foo.drv - x86_64-linux \n" port)
dc0f74e5 LC	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
976ef2d9 LC	79	(building (list (build "foo.drv" "x86_64-linux"
976ef2d9 LC	80	#:log-file "foo.log")))
dc0f74e5 LC	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
976ef2d9 LC	90	(builds-completed (list (build "foo.drv" "x86_64-linux"
976ef2d9 LC	91	#:log-file "foo.log")))
dc0f74e5 LC	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))))))
976ef2d9	108	(display "@ build-started foo.drv - x86_64-linux foo.log\n" port)
dc0f74e5 LC	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
fe17037b	120	(test-equal "build-output-port, UTF-8"
f9a8fce1	121	'((build-log #f "lambda is λ!\n"))
fe17037b LC	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?
a65177a6	130	(let ((replacement "�"))
278f86a4	131	`((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n"))))
fe17037b LC	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
f9a8fce1 LC	139	(test-equal "compute-status, multiplexed build output"
f9a8fce1 LC	140	(list (build-status
976ef2d9	141	(building (list (build "foo.drv" "x86_64-linux" #:id 121)))
f9a8fce1 LC	142	(downloading (list (download "bar" "http://example.org/bar"
	143	#:size 999
	144	#:start 'now))))
	145	(build-status
976ef2d9	146	(building (list (build "foo.drv" "x86_64-linux" #:id 121)))
f9a8fce1 LC	147	(downloading (list (download "bar" "http://example.org/bar"
	148	#:size 999
	149	#:transferred 42
	150	#:start 'now))))
	151	(build-status
976ef2d9 LC	152	;; "bar" is now only listed as a download.
976ef2d9 LC	153	(builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121)))
f9a8fce1 LC	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")))))))
976ef2d9 LC	167	(display "@ build-started foo.drv - x86_64-linux 121\n" port)
976ef2d9 LC	168	(display "@ build-started bar.drv - armhf-linux bar.log 144\n" port)
f9a8fce1 LC	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
73a8681a LC	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
ba514b60 LC	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
dc0f74e5	247	(test-end "status")