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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017 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-challenge)
  #:use-module (guix tests)
  #:use-module (gcrypt hash)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix scripts challenge)
  #:use-module (guix scripts substitute)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match))

(define query-path-hash*
  (store-lift query-path-hash))

(define* (call-with-derivation-narinfo* drv thunk hash)
  (lambda (store)
    (with-derivation-narinfo drv (sha256 => hash)
      (values (run-with-store store (thunk)) store))))

(define-syntax with-derivation-narinfo*
  (syntax-rules (sha256 =>)
    ((_ drv (sha256 => hash) body ...)
     (call-with-derivation-narinfo* drv
       (lambda () body ...)
       hash))))

\f
(test-begin "challenge")

(test-assertm "no discrepancies"
  (let ((text (random-text)))
    (mlet* %store-monad ((drv (gexp->derivation "something"
                                                #~(call-with-output-file
                                                      #$output
                                                    (lambda (port)
                                                      (display #$text port)))))
                         (out -> (derivation->output-path drv)))
      (mbegin %store-monad
        (built-derivations (list drv))
        (mlet %store-monad ((hash (query-path-hash* out)))
          (with-derivation-narinfo* drv (sha256 => hash)
            (>>= (compare-contents (list out) (%test-substitute-urls))
                 (match-lambda
                   ((report)
                    (return
                     (and (string=? out (comparison-report-item report))
                          (bytevector=?
                           (comparison-report-local-sha256 report)
                           hash)
                          (comparison-report-match? report))))))))))))

(test-assertm "one discrepancy"
  (let ((text (random-text)))
    (mlet* %store-monad ((drv (gexp->derivation "something"
                                                #~(call-with-output-file
                                                      #$output
                                                    (lambda (port)
                                                      (display #$text port)))))
                         (out -> (derivation->output-path drv)))
      (mbegin %store-monad
        (built-derivations (list drv))
        (mlet* %store-monad ((hash (query-path-hash* out))
                             (wrong-hash
                              -> (let* ((w (bytevector-copy hash))
                                        (b (bytevector-u8-ref w 0)))
                                   (bytevector-u8-set! w 0
                                                       (modulo (+ b 1) 128))
                                   w)))
          (with-derivation-narinfo* drv (sha256 => wrong-hash)
            (>>= (compare-contents (list out) (%test-substitute-urls))
                 (match-lambda
                   ((report)
                    (return
                     (and (string=? out (comparison-report-item (pk report)))
                          (eq? 'mismatch (comparison-report-result report))
                          (bytevector=? hash
                                        (comparison-report-local-sha256
                                         report))
                          (match (comparison-report-narinfos report)
                            ((bad)
                             (bytevector=? wrong-hash
                                           (narinfo-hash->sha256
                                            (narinfo-hash bad))))))))))))))))

(test-assertm "inconclusive: no substitutes"
  (mlet* %store-monad ((drv  (gexp->derivation "foo" #~(mkdir #$output)))
                       (out -> (derivation->output-path drv))
                       (_    (built-derivations (list drv)))
                       (hash (query-path-hash* out)))
    (>>= (compare-contents (list out) (%test-substitute-urls))
         (match-lambda
           ((report)
            (return
             (and (string=? out (comparison-report-item report))
                  (comparison-report-inconclusive? report)
                  (null? (comparison-report-narinfos report))
                  (bytevector=? (comparison-report-local-sha256 report)
                                hash))))))))

(test-assertm "inconclusive: no local build"
  (let ((text (random-text)))
    (mlet* %store-monad ((drv (gexp->derivation "something"
                                                #~(list #$output #$text)))
                         (out -> (derivation->output-path drv))
                         (hash -> (sha256 #vu8())))
      (with-derivation-narinfo* drv (sha256 => hash)
        (>>= (compare-contents (list out) (%test-substitute-urls))
             (match-lambda
               ((report)
                (return
                 (and (string=? out (comparison-report-item report))
                      (comparison-report-inconclusive? report)
                      (not (comparison-report-local-sha256 report))
                      (match (comparison-report-narinfos report)
                        ((narinfo)
                         (bytevector=? (narinfo-hash->sha256
                                        (narinfo-hash narinfo))
                                       hash))))))))))))


(test-end)

;;; Local Variables:
;;; eval: (put 'with-derivation-narinfo* 'scheme-indent-function 2)
;;; End:
Commit	Line	Data
d23c20f1	1	;;; GNU Guix --- Functional package management for GNU
4d8e9509	2	;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
d23c20f1 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-challenge)
	20	#:use-module (guix tests)
ca719424	21	#:use-module (gcrypt hash)
d23c20f1 LC	22	#:use-module (guix store)
	23	#:use-module (guix monads)
	24	#:use-module (guix derivations)
	25	#:use-module (guix gexp)
	26	#:use-module (guix scripts challenge)
	27	#:use-module (guix scripts substitute)
	28	#:use-module (srfi srfi-1)
	29	#:use-module (srfi srfi-26)
	30	#:use-module (srfi srfi-64)
	31	#:use-module (rnrs bytevectors)
	32	#:use-module (ice-9 match))
	33
d23c20f1 LC	34	(define query-path-hash*
	35	(store-lift query-path-hash))
	36
d23c20f1 LC	37	(define* (call-with-derivation-narinfo* drv thunk hash)
	38	(lambda (store)
	39	(with-derivation-narinfo drv (sha256 => hash)
	40	(values (run-with-store store (thunk)) store))))
	41
	42	(define-syntax with-derivation-narinfo*
	43	(syntax-rules (sha256 =>)
	44	((_ drv (sha256 => hash) body ...)
	45	(call-with-derivation-narinfo* drv
	46	(lambda () body ...)
	47	hash))))
	48
	49	\f
	50	(test-begin "challenge")
	51
	52	(test-assertm "no discrepancies"
	53	(let ((text (random-text)))
	54	(mlet* %store-monad ((drv (gexp->derivation "something"
	55	#~(call-with-output-file
	56	#$output
	57	(lambda (port)
	58	(display #$text port)))))
	59	(out -> (derivation->output-path drv)))
	60	(mbegin %store-monad
	61	(built-derivations (list drv))
	62	(mlet %store-monad ((hash (query-path-hash* out)))
	63	(with-derivation-narinfo* drv (sha256 => hash)
4d8e9509 LC	64	(>>= (compare-contents (list out) (%test-substitute-urls))
	65	(match-lambda
	66	((report)
	67	(return
	68	(and (string=? out (comparison-report-item report))
	69	(bytevector=?
	70	(comparison-report-local-sha256 report)
	71	hash)
	72	(comparison-report-match? report))))))))))))
d23c20f1 LC	73
	74	(test-assertm "one discrepancy"
	75	(let ((text (random-text)))
	76	(mlet* %store-monad ((drv (gexp->derivation "something"
	77	#~(call-with-output-file
	78	#$output
	79	(lambda (port)
	80	(display #$text port)))))
	81	(out -> (derivation->output-path drv)))
	82	(mbegin %store-monad
	83	(built-derivations (list drv))
	84	(mlet* %store-monad ((hash (query-path-hash* out))
	85	(wrong-hash
	86	-> (let* ((w (bytevector-copy hash))
	87	(b (bytevector-u8-ref w 0)))
	88	(bytevector-u8-set! w 0
	89	(modulo (+ b 1) 128))
	90	w)))
	91	(with-derivation-narinfo* drv (sha256 => wrong-hash)
4d8e9509	92	(>>= (compare-contents (list out) (%test-substitute-urls))
d23c20f1	93	(match-lambda
4d8e9509	94	((report)
d23c20f1	95	(return
4d8e9509 LC	96	(and (string=? out (comparison-report-item (pk report)))
4d8e9509 LC	97	(eq? 'mismatch (comparison-report-result report))
d23c20f1	98	(bytevector=? hash
4d8e9509 LC	99	(comparison-report-local-sha256
	100	report))
	101	(match (comparison-report-narinfos report)
d23c20f1 LC	102	((bad)
	103	(bytevector=? wrong-hash
	104	(narinfo-hash->sha256
	105	(narinfo-hash bad))))))))))))))))
	106
4d8e9509 LC	107	(test-assertm "inconclusive: no substitutes"
	108	(mlet* %store-monad ((drv (gexp->derivation "foo" #~(mkdir #$output)))
	109	(out -> (derivation->output-path drv))
	110	(_ (built-derivations (list drv)))
	111	(hash (query-path-hash* out)))
	112	(>>= (compare-contents (list out) (%test-substitute-urls))
	113	(match-lambda
	114	((report)
	115	(return
	116	(and (string=? out (comparison-report-item report))
	117	(comparison-report-inconclusive? report)
	118	(null? (comparison-report-narinfos report))
	119	(bytevector=? (comparison-report-local-sha256 report)
	120	hash))))))))
	121
	122	(test-assertm "inconclusive: no local build"
	123	(let ((text (random-text)))
	124	(mlet* %store-monad ((drv (gexp->derivation "something"
	125	#~(list #$output #$text)))
	126	(out -> (derivation->output-path drv))
	127	(hash -> (sha256 #vu8())))
	128	(with-derivation-narinfo* drv (sha256 => hash)
	129	(>>= (compare-contents (list out) (%test-substitute-urls))
	130	(match-lambda
	131	((report)
	132	(return
	133	(and (string=? out (comparison-report-item report))
	134	(comparison-report-inconclusive? report)
	135	(not (comparison-report-local-sha256 report))
	136	(match (comparison-report-narinfos report)
	137	((narinfo)
	138	(bytevector=? (narinfo-hash->sha256
	139	(narinfo-hash narinfo))
	140	hash))))))))))))
	141
	142
d23c20f1 LC	143	(test-end)
d23c20f1 LC	144
d23c20f1 LC	145	;;; Local Variables:
	146	;;; eval: (put 'with-derivation-narinfo* 'scheme-indent-function 2)
	147	;;; End: