;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 John Darrington <jmd@gnu.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;;
;;; 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 (gnu packages cook)
  #:use-module (guix packages)
  #:use-module (guix licenses)
  #:use-module (guix download)
  #:use-module (gnu packages bison)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages groff)
  #:use-module (gnu packages text-editors)
  #:use-module (guix build-system gnu))

(define-public cook
  (package
    (name "cook")
    (version "2.34")
    (source
     (origin
       (method url-fetch)
       (uri "http://fossies.org/linux/misc/old/cook-2.34.tar.gz")
       (sha256
        (base32
         "104saqnqql1l7zr2pm3f718fdky3ds8j07c6xvwrs1rfkhrw58yw"))))
    (build-system gnu-build-system)
    (arguments
     `(#:parallel-build? #f ; There are some nasty racy rules in the Makefile.
       #:phases
       (modify-phases %standard-phases
         (add-before 'configure 'pre-conf
           (lambda _
             (substitute* (append '("common/env.c")
                                  (find-files "test" "\\.sh"))
               (("/bin/sh") (which "sh")))

             ;; Guix's binutils (because it wants bit-reproducable builds) is
             ;; is configured with the  --enable-deterministic-archives flag.
             ;; This means the timestamp of files appended to an ar archive
             ;; are automatically and silently mutated to 00:00 1 Jan 1970
             ;; which plays havoc with this test, for which correct timestamps
             ;; are very important. Adding the U flag undoes the effect of
             ;; --enable-deterministic-archives and allows this test to work
             ;; again.
             (substitute* "test/00/t0077a.sh"
               (("ar qc") "ar qcU"))

             ;; Guix builds have LC_ALL set to "en_US.utf8", which causes
             ;; `date` to use a 12-hour clock instead of 24h, which in turn
             ;; makes t0217a.sh fail because of unexpected date output.
             (substitute* "test/02/t0217a.sh"
               (("export TZ")
                "export TZ\nLC_ALL=POSIX\nexport LC_ALL"))

             (setenv "SH" (which "sh"))
             #t)))))
    (native-inputs (list bison-3.0
                         ;; For building the documentation:
                         groff
                         ;; For the tests:
                         sharutils
                         ;; One test wants rsh.  However there is no rsh server
                         ;; running in the build environment and so far as I'm
                         ;; aware, it cannot be started without root.
                         ;; This test is therefore just skipped.
                         ;; ("inetutils" ,inetutils)
                         ed))
    (home-page (string-append "https://web.archive.org/web/20140727122520/"
                              "http://miller.emu.id.au/pmiller/software/cook/"))
    (synopsis "Tool for constructing files")
    (description "Cook is a tool for constructing files.  It is given a set of
files to create, and recipes of how to create them.  In any non-trivial program
there will be prerequisites to performing the actions necessary to creating
any file, such as include files.  Cook provides a mechanism to define these.")
    (license gpl3+)))
rison-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 -> (gcrypt: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))) (define (call-mismatch-test proc) "Pass PROC a <comparison-report> for a mismatch and return its return value." ;; Pretend we have two different results for the same store item, ITEM, with ;; "/bin/guile" differing between the two nars. (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) "/" (bytevector->nix-base32-string (random-bytevector 32)) "-foo" (number->string (current-time) 16)))) (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 (proc (car reports)))))))))))) (test-assertm "differing-files" (call-mismatch-test (lambda (report) (equal? (differing-files report) '("/bin/guile"))))) (test-assertm "call-with-mismatches" (call-mismatch-test (lambda (report) (call-with-mismatches report (lambda (directory1 directory2) (let* ((files1 (find-files directory1)) (files2 (find-files directory2)) (files (map (cute string-drop <> (string-length directory1)) files1))) (and (equal? files (map (cute string-drop <> (string-length directory2)) files2)) (equal? (remove (lambda (file) (file=? (string-append directory1 "/" file) (string-append directory2 "/" file))) files) '("/bin/guile"))))))))) (test-end) ;;; Local Variables: ;;; eval: (put 'with-derivation-narinfo* 'scheme-indent-function 2) ;;; End: