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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019 Caleb Ristvedt <caleb.ristvedt@cune.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/>.
(define-module (guix store files)
#:use-module (ice-9 regex)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:use-module (gcrypt hash)
#:use-module (guix base32)
#:use-module (guix base16)
#:use-module (guix config)
#:use-module (guix memoization)
#:export (&store-error
store-error?
%store-prefix
store-path
output-path
fixed-output-path
store-path?
direct-store-path?
derivation-path?
store-path-base
store-path-package-name
store-path-hash-part
direct-store-path
derivation-log-file
log-file
compressed-hash))
(define-condition-type &store-error &error
store-error?)
;;;
;;; Store paths.
;;;
(define %store-prefix
;; Absolute path to the Nix store.
(make-parameter %store-directory))
(define (compressed-hash bv size) ; `compressHash'
"Given the hash stored in BV, return a compressed version thereof that fits
in SIZE bytes."
(define new (make-bytevector size 0))
(define old-size (bytevector-length bv))
(let loop ((i 0))
(if (= i old-size)
new
(let* ((j (modulo i size))
(o (bytevector-u8-ref new j)))
(bytevector-u8-set! new j
(logxor o (bytevector-u8-ref bv i)))
(loop (+ 1 i))))))
(define (store-path type hash name) ; makeStorePath
"Return the store path for NAME/HASH/TYPE."
(let* ((s (string-append type ":sha256:"
(bytevector->base16-string hash) ":"
(%store-prefix) ":" name))
(h (sha256 (string->utf8 s)))
(c (compressed-hash h 20)))
(string-append (%store-prefix) "/"
(bytevector->nix-base32-string c) "-"
name)))
(define (output-path output hash name) ; makeOutputPath
"Return an output path for OUTPUT (the name of the output as a string) of
the derivation called NAME with hash HASH."
(store-path (string-append "output:" output) hash
(if (string=? output "out")
name
(string-append name "-" output))))
(define* (fixed-output-path name hash
#:key
(output "out")
(hash-algo 'sha256)
(recursive? #t))
"Return an output path for the fixed output OUTPUT defined by HASH of type
HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for
'add-to-store'."
(if (and recursive? (eq? hash-algo 'sha256))
(store-path "source" hash name)
(let ((tag (string-append "fixed:" output ":"
(if recursive? "r:" "")
(symbol->string hash-algo) ":"
(bytevector->base16-string hash) ":")))
(store-path (string-append "output:" output)
(sha256 (string->utf8 tag))
name))))
(define (store-path? path)
"Return #t if PATH is a store path."
;; This is a lightweight check, compared to using a regexp, but this has to
;; be fast as it's called often in `derivation', for instance.
;; `isStorePath' in Nix does something similar.
(string-prefix? (%store-prefix) path))
(define (direct-store-path? path)
"Return #t if PATH is a store path, and not a sub-directory of a store path.
This predicate is sometimes needed because files *under* a store path are not
valid inputs."
(and (store-path? path)
(not (string=? path (%store-prefix)))
(let ((len (+ 1 (string-length (%store-prefix)))))
(not (string-index (substring path len) #\/)))))
(define (direct-store-path path)
"Return the direct store path part of PATH, stripping components after
'/gnu/store/xxxx-foo'."
(let ((prefix-length (+ (string-length (%store-prefix)) 35)))
(if (> (string-length path) prefix-length)
(let ((slash (string-index path #\/ prefix-length)))
(if slash (string-take path slash) path))
path)))
(define (derivation-path? path)
"Return #t if PATH is a derivation path."
(and (store-path? path) (string-suffix? ".drv" path)))
(define (store-path-base path)
"Return the base path of a path in the store."
(and (string-prefix? (%store-prefix) path)
(let ((base (string-drop path (+ 1 (string-length (%store-prefix))))))
(and (> (string-length base) 33)
(not (string-index base #\/))
base))))
(define (store-path-package-name path)
"Return the package name part of PATH, a file name in the store."
(let ((base (store-path-base path)))
(string-drop base (+ 32 1)))) ;32 hash part + 1 hyphen
(define (store-path-hash-part path)
"Return the hash part of PATH as a base32 string, or #f if PATH is not a
syntactically valid store path."
(let* ((base (store-path-base path))
(hash (string-take base 32)))
(and (string-every %nix-base32-charset hash)
hash)))
(define (derivation-log-file drv)
"Return the build log file for DRV, a derivation file name, or #f if it
could not be found."
(let* ((base (basename drv))
(log (string-append (or (getenv "GUIX_LOG_DIRECTORY")
(string-append %localstatedir "/log/guix"))
"/drvs/"
(string-take base 2) "/"
(string-drop base 2)))
(log.gz (string-append log ".gz"))
(log.bz2 (string-append log ".bz2")))
(cond ((file-exists? log.gz) log.gz)
((file-exists? log.bz2) log.bz2)
((file-exists? log) log)
(else #f))))
|
