You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

156 lines
6.5 KiB

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