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

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

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

(define (query-path-size item)
  (mlet %store-monad ((info (query-path-info* item)))
    (return (path-info-nar-size info))))

(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))))))))))))
(define (make-narinfo item size hash)
  (format #f "StorePath: ~a
Compression: none
URL: nar/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
NarSize: ~d
NarHash: sha256:~a
References: ~%" item size (bytevector->nix-base32-string hash)))

(test-assertm "differing-files"
  ;; Pretend we have two different results for the same store item, ITEM,
  ;; with "/bin/guile" differing between the two nars, and make sure
  ;; 'differing-files' returns it.
  (mlet* %store-monad
      ((drv1 (package->derivation %bootstrap-guile))
       (drv2 (gexp->derivation
              "broken-guile"
              (with-imported-modules '((guix build utils))
                #~(begin
                    (use-modules (guix build utils))
                    (copy-recursively #$drv1 #$output)
                    (chmod (string-append #$output "/bin/guile")
                           #o755)
                    (call-with-output-file (string-append
                                            #$output
                                            "/bin/guile")
                      (lambda (port)
                        (display "corrupt!" port)))))))
       (out1 -> (derivation->output-path drv1))
       (out2 -> (derivation->output-path drv2))
       (item -> (string-append (%store-prefix) "/"
                               (make-string 32 #\a) "-foo")))
    (mbegin %store-monad
      (built-derivations (list drv1 drv2))
      (mlet* %store-monad ((size1 (query-path-size out1))
                           (size2 (query-path-size out2))
                           (hash1 (query-path-hash* out1))
                           (hash2 (query-path-hash* out2))
                           (nar1 -> (call-with-bytevector-output-port
                                      (lambda (port)
                                        (write-file out1 port))))
                           (nar2 -> (call-with-bytevector-output-port
                                      (lambda (port)
                                        (write-file out2 port)))))
        (parameterize ((%http-server-port 9000))
          (with-http-server `((200 ,(make-narinfo item size1 hash1))
                              (200 ,nar1))
            (parameterize ((%http-server-port 9001))
              (with-http-server `((200 ,(make-narinfo item size2 hash2))
                                  (200 ,nar2))
                (mlet* %store-monad ((urls -> (list (%local-url 9000)
                                                    (%local-url 9001)))
                                     (reports (compare-contents (list item)
                                                                urls)))
                  (pk 'report reports)
                  (return (equal? (differing-files (car reports))
                                  '("/bin/guile"))))))))))))

(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
5208db3a	2	;;; Copyright © 2015, 2017, 2019 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)
5208db3a	21	#:use-module (guix tests http)
ca719424	22	#:use-module (gcrypt hash)
d23c20f1 LC	23	#:use-module (guix store)
	24	#:use-module (guix monads)
	25	#:use-module (guix derivations)
5208db3a LC	26	#:use-module (guix serialization)
5208db3a LC	27	#:use-module (guix packages)
d23c20f1	28	#:use-module (guix gexp)
5208db3a	29	#:use-module (guix base32)
d23c20f1 LC	30	#:use-module (guix scripts challenge)
d23c20f1 LC	31	#:use-module (guix scripts substitute)
5208db3a	32	#:use-module (gnu packages bootstrap)
d23c20f1 LC	33	#:use-module (srfi srfi-1)
	34	#:use-module (srfi srfi-26)
	35	#:use-module (srfi srfi-64)
	36	#:use-module (rnrs bytevectors)
5208db3a	37	#:use-module (rnrs io ports)
d23c20f1 LC	38	#:use-module (ice-9 match))
d23c20f1 LC	39
d23c20f1 LC	40	(define query-path-hash*
	41	(store-lift query-path-hash))
	42
5208db3a LC	43	(define (query-path-size item)
	44	(mlet %store-monad ((info (query-path-info* item)))
	45	(return (path-info-nar-size info))))
	46
d23c20f1 LC	47	(define* (call-with-derivation-narinfo* drv thunk hash)
	48	(lambda (store)
	49	(with-derivation-narinfo drv (sha256 => hash)
	50	(values (run-with-store store (thunk)) store))))
	51
	52	(define-syntax with-derivation-narinfo*
	53	(syntax-rules (sha256 =>)
	54	((_ drv (sha256 => hash) body ...)
	55	(call-with-derivation-narinfo* drv
	56	(lambda () body ...)
	57	hash))))
	58
	59	\f
	60	(test-begin "challenge")
	61
	62	(test-assertm "no discrepancies"
	63	(let ((text (random-text)))
	64	(mlet* %store-monad ((drv (gexp->derivation "something"
	65	#~(call-with-output-file
	66	#$output
	67	(lambda (port)
	68	(display #$text port)))))
	69	(out -> (derivation->output-path drv)))
	70	(mbegin %store-monad
	71	(built-derivations (list drv))
	72	(mlet %store-monad ((hash (query-path-hash* out)))
	73	(with-derivation-narinfo* drv (sha256 => hash)
4d8e9509 LC	74	(>>= (compare-contents (list out) (%test-substitute-urls))
	75	(match-lambda
	76	((report)
	77	(return
	78	(and (string=? out (comparison-report-item report))
	79	(bytevector=?
	80	(comparison-report-local-sha256 report)
	81	hash)
	82	(comparison-report-match? report))))))))))))
d23c20f1 LC	83
	84	(test-assertm "one discrepancy"
	85	(let ((text (random-text)))
	86	(mlet* %store-monad ((drv (gexp->derivation "something"
	87	#~(call-with-output-file
	88	#$output
	89	(lambda (port)
	90	(display #$text port)))))
	91	(out -> (derivation->output-path drv)))
	92	(mbegin %store-monad
	93	(built-derivations (list drv))
	94	(mlet* %store-monad ((hash (query-path-hash* out))
	95	(wrong-hash
	96	-> (let* ((w (bytevector-copy hash))
	97	(b (bytevector-u8-ref w 0)))
	98	(bytevector-u8-set! w 0
	99	(modulo (+ b 1) 128))
	100	w)))
	101	(with-derivation-narinfo* drv (sha256 => wrong-hash)
4d8e9509	102	(>>= (compare-contents (list out) (%test-substitute-urls))
d23c20f1	103	(match-lambda
4d8e9509	104	((report)
d23c20f1	105	(return
4d8e9509 LC	106	(and (string=? out (comparison-report-item (pk report)))
4d8e9509 LC	107	(eq? 'mismatch (comparison-report-result report))
d23c20f1	108	(bytevector=? hash
4d8e9509 LC	109	(comparison-report-local-sha256
	110	report))
	111	(match (comparison-report-narinfos report)
d23c20f1 LC	112	((bad)
	113	(bytevector=? wrong-hash
	114	(narinfo-hash->sha256
	115	(narinfo-hash bad))))))))))))))))
	116
4d8e9509 LC	117	(test-assertm "inconclusive: no substitutes"
	118	(mlet* %store-monad ((drv (gexp->derivation "foo" #~(mkdir #$output)))
	119	(out -> (derivation->output-path drv))
	120	(_ (built-derivations (list drv)))
	121	(hash (query-path-hash* out)))
	122	(>>= (compare-contents (list out) (%test-substitute-urls))
	123	(match-lambda
	124	((report)
	125	(return
	126	(and (string=? out (comparison-report-item report))
	127	(comparison-report-inconclusive? report)
	128	(null? (comparison-report-narinfos report))
	129	(bytevector=? (comparison-report-local-sha256 report)
	130	hash))))))))
	131
	132	(test-assertm "inconclusive: no local build"
	133	(let ((text (random-text)))
	134	(mlet* %store-monad ((drv (gexp->derivation "something"
	135	#~(list #$output #$text)))
	136	(out -> (derivation->output-path drv))
	137	(hash -> (sha256 #vu8())))
	138	(with-derivation-narinfo* drv (sha256 => hash)
	139	(>>= (compare-contents (list out) (%test-substitute-urls))
	140	(match-lambda
	141	((report)
	142	(return
	143	(and (string=? out (comparison-report-item report))
	144	(comparison-report-inconclusive? report)
	145	(not (comparison-report-local-sha256 report))
	146	(match (comparison-report-narinfos report)
	147	((narinfo)
	148	(bytevector=? (narinfo-hash->sha256
	149	(narinfo-hash narinfo))
	150	hash))))))))))))
5208db3a LC	151	(define (make-narinfo item size hash)
	152	(format #f "StorePath: ~a
	153	Compression: none
	154	URL: nar/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
	155	NarSize: ~d
	156	NarHash: sha256:~a
	157	References: ~%" item size (bytevector->nix-base32-string hash)))
4d8e9509	158
5208db3a LC	159	(test-assertm "differing-files"
	160	;; Pretend we have two different results for the same store item, ITEM,
	161	;; with "/bin/guile" differing between the two nars, and make sure
	162	;; 'differing-files' returns it.
	163	(mlet* %store-monad
	164	((drv1 (package->derivation %bootstrap-guile))
	165	(drv2 (gexp->derivation
	166	"broken-guile"
	167	(with-imported-modules '((guix build utils))
	168	#~(begin
	169	(use-modules (guix build utils))
	170	(copy-recursively #$drv1 #$output)
	171	(chmod (string-append #$output "/bin/guile")
	172	#o755)
	173	(call-with-output-file (string-append
	174	#$output
	175	"/bin/guile")
	176	(lambda (port)
	177	(display "corrupt!" port)))))))
	178	(out1 -> (derivation->output-path drv1))
	179	(out2 -> (derivation->output-path drv2))
	180	(item -> (string-append (%store-prefix) "/"
	181	(make-string 32 #\a) "-foo")))
	182	(mbegin %store-monad
	183	(built-derivations (list drv1 drv2))
	184	(mlet* %store-monad ((size1 (query-path-size out1))
	185	(size2 (query-path-size out2))
	186	(hash1 (query-path-hash* out1))
	187	(hash2 (query-path-hash* out2))
	188	(nar1 -> (call-with-bytevector-output-port
	189	(lambda (port)
	190	(write-file out1 port))))
	191	(nar2 -> (call-with-bytevector-output-port
	192	(lambda (port)
	193	(write-file out2 port)))))
	194	(parameterize ((%http-server-port 9000))
	195	(with-http-server `((200 ,(make-narinfo item size1 hash1))
	196	(200 ,nar1))
	197	(parameterize ((%http-server-port 9001))
	198	(with-http-server `((200 ,(make-narinfo item size2 hash2))
	199	(200 ,nar2))
	200	(mlet* %store-monad ((urls -> (list (%local-url 9000)
	201	(%local-url 9001)))
	202	(reports (compare-contents (list item)
	203	urls)))
	204	(pk 'report reports)
	205	(return (equal? (differing-files (car reports))
	206	'("/bin/guile"))))))))))))
4d8e9509	207
d23c20f1 LC	208	(test-end)
d23c20f1 LC	209
d23c20f1 LC	210	;;; Local Variables:
	211	;;; eval: (put 'with-derivation-narinfo* 'scheme-indent-function 2)
	212	;;; End: