etc/disarchive-manifest.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2021-2022 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
  19 ;;; This file returns a manifest that builds a directory containing Disarchive
  20 ;;; metadata for all the tarballs packages refer to.
  21
  22 (use-modules (srfi srfi-1) (ice-9 match)
  23              (guix packages) (guix gexp) (guix profiles)
  24              (guix base16)
  25              (gnu packages))
  26
  27 (include "source-manifest.scm")
  28
  29 (define (tarball-origin? origin)
  30   (match (origin-actual-file-name origin)
  31     (#f #f)
  32     ((? string? file)
  33      ;; As of version 0.4.0, Disarchive can only deal with raw tarballs,
  34      ;; gzip-compressed tarballs, and xz-compressed tarballs.
  35      (and (origin-hash origin)
  36           (or (string-suffix? ".tar.gz" file)
  37               (string-suffix? ".tgz" file)
  38               (string-suffix? ".tar.xz" file)
  39               (string-suffix? ".tar" file))))))
  40
  41 (define (origin->disarchive origin)
  42   "Return a directory containing Disarchive metadata for ORIGIN, a tarball, or
  43 an empty directory if ORIGIN could not be disassembled."
  44   (define file-name
  45     (let ((hash (origin-hash origin)))
  46       (string-append (symbol->string (content-hash-algorithm hash))
  47                      "/"
  48                      (bytevector->base16-string
  49                       (content-hash-value hash)))))
  50
  51   (define disarchive
  52     (specification->package "disarchive"))
  53
  54   (define build
  55     (with-imported-modules '((guix build utils))
  56       #~(begin
  57           (use-modules (guix build utils)
  58                        (srfi srfi-34))
  59
  60           (define tarball
  61             #+(upstream-origin origin))
  62
  63           (define file-name
  64             (string-append #$output "/" #$file-name))
  65
  66           (define profile
  67             #+(profile (content (packages->manifest (list disarchive)))))
  68
  69           (mkdir-p (dirname file-name))
  70           (setenv "PATH" (string-append profile "/bin"))
  71           (setenv "GUILE_LOAD_PATH"
  72                   (string-append profile "/share/guile/site/"
  73                                  (effective-version)))
  74           (setenv "GUILE_LOAD_COMPILED_PATH"
  75                   (string-append profile "/lib/guile/" (effective-version)
  76                                  "/site-ccache"))
  77
  78           (guard (c ((invoke-error? c)
  79                      ;; Sometimes Disarchive fails with "could not find Gzip
  80                      ;; compressor".  When that happens, produce an empty
  81                      ;; directory instead of failing.
  82                      (report-invoke-error c)
  83                      (delete-file file-name)))
  84             (with-output-to-file file-name
  85               (lambda ()
  86                 ;; Disarchive records the tarball name in its output.  Thus,
  87                 ;; strip the hash from TARBALL.
  88                 (let ((short-name (strip-store-file-name tarball)))
  89                   (symlink tarball short-name)
  90                   (invoke "disarchive" "disassemble" short-name))))))))
  91
  92   (computed-file (match (origin-actual-file-name origin)
  93                    ((? string? str) (string-append str ".dis"))
  94                    (#f "anonymous-tarball.dis"))
  95                  build))
  96
  97 (define (disarchive-collection origins)
  98   "Return a directory containing all the Disarchive metadata for ORIGINS."
  99   (directory-union "disarchive-collection"
 100                    (filter-map (lambda (origin)
 101                                  (and (tarball-origin? origin)
 102
 103                                       ;; Dismiss origins with (sha256 #f) such
 104                                       ;; as that of IceCat.
 105                                       (and=> (origin-hash origin)
 106                                              content-hash-value)
 107
 108                                       ;; FIXME: Exclude the Chromium tarball
 109                                       ;; because it's huge and "disarchive
 110                                       ;; disassemble" exceeds the max-silent
 111                                       ;; timeout.
 112                                       (not (string-prefix?
 113                                             "chromium-"
 114                                             (origin-actual-file-name origin)))
 115
 116                                       (origin->disarchive origin)))
 117                                origins)
 118                    #:copy? #t))
 119
 120 \f
 121 ;; The manifest containing Disarchive data.
 122 (let ((origins (all-origins)))
 123   (manifest
 124    (list (manifest-entry
 125            (name "disarchive-collection")
 126            (version (number->string (length origins)))
 127            (item (disarchive-collection origins))))))