Commit | Line | Data |
---|---|---|
98712c14 | 1 | ;;; GNU Guix --- Functional package management for GNU |
2acffd56 | 2 | ;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> |
98712c14 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 | ;;; 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) | |
2acffd56 LC |
33 | ;; As of version 0.4.0, Disarchive can only deal with raw tarballs, |
34 | ;; gzip-compressed tarballs, and xz-compressed tarballs. | |
98712c14 LC |
35 | (and (origin-hash origin) |
36 | (or (string-suffix? ".tar.gz" file) | |
37 | (string-suffix? ".tgz" file) | |
2acffd56 | 38 | (string-suffix? ".tar.xz" file) |
98712c14 LC |
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) | |
6d4a0cce LC |
102 | |
103 | ;; Dismiss origins with (sha256 #f) such | |
104 | ;; as that of IceCat. | |
105 | (and=> (origin-hash origin) | |
106 | content-hash-value) | |
107 | ||
eab5366e LC |
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 | ||
98712c14 LC |
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") | |
2ad1ef84 | 126 | (version (number->string (length origins))) |
98712c14 | 127 | (item (disarchive-collection origins)))))) |