summaryrefslogtreecommitdiff
path: root/guix/build/node-build-system.scm
blob: fb23894bc1951e4e5e2b31310b92ad36fe370bc0 (about) (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
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
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016, 2020 Jelle Licht <jlicht@fsfe.org>
;;; Copyright © 2019, 2021 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2021, 2022 Philip McGrath <philip@philipmcgrath.com>
;;; Copyright © 2022 Liliana Marie Prikler <liliana.prikler@gmail.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 (guix build node-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (guix build json)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-71)
  #:export (%standard-phases
            with-atomic-json-file-replacement
            delete-dependencies
            node-build))

(define (with-atomic-json-file-replacement file proc)
  "Like 'with-atomic-file-replacement', but PROC is called with a single
argument---the result of parsing FILE's contents as json---and should a value
to be written as json to the replacement FILE."
  (with-atomic-file-replacement file
    (lambda (in out)
      (write-json (proc (read-json in)) out))))

(define* (assoc-ref* alist key #:optional default)
  "Like assoc-ref, but return DEFAULT instead of #f if no value exists."
  (match (assoc key alist)
    (#f default)
    ((_ . value) value)))

(define* (jsobject-ref obj key #:optional default)
  (match obj
    (('@ . alist) (assoc-ref* alist key default))))

(define* (alist-pop alist key #:optional (= equal?))
  "Return two values, the first pair in ALIST with key KEY, and the other
elements.  Equality calls are made as (= KEY ALISTCAR)."
  (define (found? pair)
    (= key (car pair)))

  (let ((before after (break found? alist)))
    (if (pair? after)
        (values (car after) (append before (cdr after)))
        (values #f before))))

(define* (alist-update alist key proc #:optional default (= equal?))
  "Return an association list like ALIST, but with KEY mapped to the result of
PROC applied to the first value found under the comparison (= KEY ALISTCAR).
If no such value exists, use DEFAULT instead.
Unlike acons, this removes the previous association of KEY (assuming it is
unique), but the result may still share storage with ALIST."
  (let ((pair rest (alist-pop alist key =)))
    (acons key
           (proc (if (pair? pair)
                     (cdr pair)
                     default))
           rest)))

(define (jsobject-update* js . updates)
  "Return a json object like JS, but with all UPDATES applied.  Each update is
a list (KEY PROC [DEFAULT]), so that KEY is mapped to the result of PROC
applied to the value to which KEY is mapped in JS.  If no such mapping exists,
PROC is instead applied to DEFAULT, or to '#f' is no DEFAULT is specified.
The update takes place from left to right, so later UPDATERs will receive the
values returned by earlier UPDATERs for the same KEY."
  (match js
    (('@ . alist)
     (let loop ((alist alist)
                (updates updates))
       (match updates
         (() (cons '@ alist))
         (((key proc) . updates)
          (loop (alist-update alist key proc #f equal?) updates))
         (((key proc default) . updates)
          (loop (alist-update alist key proc default equal?) updates)))))))

(define (jsobject-union combine seed . objects)
  "Merge OBJECTS into SEED by applying (COMBINE KEY VAL0 VAL), where VAL0
is the value found in the (possibly updated) SEED and VAL is the new value
found in one of the OBJECTS."
  (match seed
    (('@ . aseed)
     (match objects
       (() seed)
       ((('@ . alists) ...)
        (cons
         '@
         (fold (lambda (alist aseed)
                 (if (null? aseed) alist
                     (fold
                      (match-lambda*
                        (((k . v) aseed)
                         (let ((pair tail (alist-pop alist k)))
                           (match pair
                             (#f (acons k v aseed))
                             ((_ . v0) (acons k (combine k v0 v) aseed))))))
                      aseed
                      alist)))
               aseed
               alists)))))))

;; Possibly useful helper functions:
;; (define (newest key val0 val) val)
;; (define (unkeyed->keyed proc) (lambda (_key val0 val) (proc val0 val)))


;;;
;;; Phases.
;;;

(define (set-home . _)
  (with-directory-excursion ".."
    (let loop ((i 0))
      (let ((dir (string-append "npm-home-" (number->string i))))
        (if (directory-exists? dir)
            (loop (1+ i))
            (begin
              (mkdir dir)
              (setenv "HOME" (string-append (getcwd) "/" dir))
              (format #t "set HOME to ~s~%" (getenv "HOME")))))))
  #t)

(define (module-name module)
  (let* ((package.json (string-append module "/package.json"))
         (package-meta (call-with-input-file package.json read-json)))
    (jsobject-ref package-meta "name")))

(define (index-modules input-paths)
  (define (list-modules directory)
    (append-map (lambda (x)
                  (if (string-prefix? "@" x)
                      (list-modules (string-append directory "/" x))
                      (list (string-append directory "/" x))))
                (filter (lambda (x)
                          (not (member x '("." ".."))))
                        (or (scandir directory) '()))))
  (let ((index (make-hash-table (* 2 (length input-paths)))))
    (for-each (lambda (dir)
                (let ((nm (string-append dir "/lib/node_modules")))
                  (for-each (lambda (module)
                              (hash-set! index (module-name module) module))
                            (list-modules nm))))
              input-paths)
    index))

(define* (patch-dependencies #:key inputs #:allow-other-keys)

  (define index (index-modules (map cdr inputs)))

  (define resolve-dependencies
    (match-lambda
      (('@ . alist)
       (cons '@ (map (match-lambda
                       ((key . value)
                        (cons key (hash-ref index key value))))
                     alist)))))

  (with-atomic-json-file-replacement "package.json"
    (lambda (pkg-meta)
      (jsobject-update*
       pkg-meta
       `("devDependencies" ,resolve-dependencies (@))
       `("dependencies" ,(lambda (deps)
                           (resolve-dependencies
                            (jsobject-union
                             (lambda (k a b) b)
                             (jsobject-ref pkg-meta "peerDependencies" '(@))
                             deps)))
         (@)))))
  #t)

(define (delete-dependencies absent)
  "Rewrite 'package.json' to allow the build to proceed without packages
listed in ABSENT, a list of strings naming npm packages.

To prevent the deleted dependencies from being reintroduced, use this function
only after the 'patch-dependencies' phase."
  (define delete-from-jsobject
    (match-lambda
      (('@ . alist)
       (cons '@ (filter (match-lambda
                          ((k . _)
                           (not (member k absent))))
                        alist)))))

  (with-atomic-json-file-replacement "package.json"
    (lambda (pkg-meta)
      (jsobject-update*
       pkg-meta
       `("devDependencies" ,delete-from-jsobject (@))
       `("dependencies" ,delete-from-jsobject (@))
       `("peerDependencies" ,delete-from-jsobject (@))))))

(define* (delete-lockfiles #:key inputs #:allow-other-keys)
  "Delete 'package-lock.json', 'yarn.lock', and 'npm-shrinkwrap.json', if they
exist."
  (for-each (lambda (pth)
              (when (file-exists? pth)
                (delete-file pth)))
            '("package-lock.json"
              "yarn.lock"
              "npm-shrinkwrap.json"))
  #t)

(define* (configure #:key outputs inputs #:allow-other-keys)
  (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
    (invoke npm "--offline" "--ignore-scripts" "--install-links" "install")
    #t))

(define* (build #:key inputs #:allow-other-keys)
  (let ((package-meta (call-with-input-file "package.json" read-json)))
    (if (jsobject-ref (jsobject-ref package-meta "scripts" '(@)) "build" #f)
        (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
          (invoke npm "run" "build"))
        (format #t "there is no build script to run~%"))
    #t))

(define* (check #:key tests? inputs #:allow-other-keys)
  "Run 'npm test' if TESTS?"
  (if tests?
      (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
        (invoke npm "test"))
      (format #t "test suite not run~%"))
  #t)

(define* (repack #:key inputs #:allow-other-keys)
  (invoke "tar"
          ;; Add options suggested by https://reproducible-builds.org/docs/archives/
          "--sort=name"
          (string-append "--mtime=@" (getenv "SOURCE_DATE_EPOCH"))
          "--owner=0"
          "--group=0"
          "--numeric-owner"
          "-czf" "../package.tgz" ".")
  #t)

(define* (install #:key outputs inputs #:allow-other-keys)
  "Install the node module to the output store item."
  (let ((out (assoc-ref outputs "out"))
        (npm (string-append (assoc-ref inputs "node") "/bin/npm")))
    (invoke npm "--prefix" out
            "--global"
            "--offline"
            "--loglevel" "info"
            "--production"
            "--install-links"
            "install" "../package.tgz")
    #t))

(define* (avoid-node-gyp-rebuild #:key outputs #:allow-other-keys)
  "Adjust the installed 'package.json' to remove an 'install' script that
would try to run 'node-gyp rebuild'."
  ;; We want to take advantage of `npm install`'s automatic support for
  ;; building native addons with node-gyp: in particular, it helps us avoid
  ;; hard-coding the specifics of how npm's internal copy of node-gyp is
  ;; currently packaged. However, the mechanism by which the automatic support
  ;; is implemented causes problems for us.
  ;;
  ;; If a package contains a 'binding.gyp' file and does not define an
  ;; 'install' or 'preinstall' script, 'npm install' runs a default install
  ;; script consisting of 'node-gyp rebuild'. In our 'install' phase, this
  ;; implicit 'install' script, if it is applicable, is explicitly added to
  ;; the "package.json" file. However, if another Guix package were to use a
  ;; Node.js package with such an 'install' script, the dependent package's
  ;; build process would fail, because 'node-gyp rebuild' would try to write
  ;; to the store.
  ;;
  ;; Here, if the installed "package.json" defines scripts.install as
  ;; "node-gyp rebuild", we replace it with a no-op. Importantly, deleting the
  ;; install script definition would not be enough, because the default
  ;; install script would cause the same problem.
  ;;
  ;; For further details, see:
  ;; - https://docs.npmjs.com/cli/v8/configuring-npm/package-json#default-values
  ;; - https://docs.npmjs.com/cli/v8/using-npm/scripts#best-practices
  (define installed-package.json
    (search-input-file outputs (string-append "/lib/node_modules/"
                                              (module-name ".")
                                              "/package.json")))
  ;; We don't want to use an atomic replacement here, because we often don't
  ;; even need to overwrite this file.  Therefore, let's use some helpers
  ;; that we'd otherwise not need.
  (define pkg-meta
    (call-with-input-file installed-package.json read-json))
  (define scripts
    (jsobject-ref pkg-meta "scripts" '(@)))
  (define (jsobject-set js key val)
    (jsobject-update* js (list key (const val))))

  (when (equal? "node-gyp rebuild" (jsobject-ref scripts "install" #f))
    (call-with-output-file installed-package.json
      (lambda (out)
        (write-json
         (jsobject-set pkg-meta
                       "scripts"
                       (jsobject-set scripts
                                     "install"
                                     "echo Guix: avoiding node-gyp rebuild"))
         out)))))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (add-after 'unpack 'set-home set-home)
    (add-before 'configure 'patch-dependencies patch-dependencies)
    (add-after 'patch-dependencies 'delete-lockfiles delete-lockfiles)
    (replace 'configure configure)
    (replace 'build build)
    (replace 'check check)
    (add-before 'install 'repack repack)
    (replace 'install install)
    (add-after 'install 'avoid-node-gyp-rebuild avoid-node-gyp-rebuild)))

(define* (node-build #:key inputs (phases %standard-phases)
                     #:allow-other-keys #:rest args)
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))