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