summary refs log tree commit diff
path: root/emacs/guix-main.scm
blob: 1383d088306bf44644566b6d54f4e000d4f4f6b4 (plain) (blame)
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
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Alex Kost <alezost@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/>.

;;; Commentary:

;; Information about packages and generations is passed to the elisp
;; side in the form of alists of parameters (such as ‘name’ or
;; ‘version’) and their values.  These alists are called "entries" in
;; this code.  So to distinguish, just "package" in the name of a
;; function means a guile object ("package" record) while
;; "package entry" means alist of package parameters and values (see
;; ‘package-param-alist’).
;;
;; "Entry" is probably not the best name for such alists, because there
;; already exists "manifest-entry" which has nothing to do with the
;; "entry" described above.  Do not be confused :)

;; ‘get-entries’ function is the “entry point” for the elisp side to get
;; information about packages and generations.

;; Since name/version pair is not necessarily unique, we use
;; `object-address' to identify a package (for ‘id’ parameter), if
;; possible.  However for the obsolete packages (that can be found in
;; installed manifest but not in a package directory), ‘id’ parameter is
;; still "name-version" string.  So ‘id’ package parameter in the code
;; below is either an object-address number or a full-name string.
;;
;; Important: as object addresses live only during guile session, elisp
;; part should take care about updating information after "Guix REPL" is
;; restarted (TODO!)
;;
;; ‘installed’ parameter of a package entry contains information about
;; installed outputs.  It is a list of "installed entries" (see
;; ‘package-installed-param-alist’).

;; To speed-up the process of getting information, the following
;; auxiliary variables are used:
;;
;; - `%packages' - VHash of "package address"/"package" pairs.
;;
;; - `%package-table' - Hash table of
;;   "name+version key"/"list of packages" pairs.
;;
;; - `%current-manifest-entries-table' - Hash table of
;;   "name+version key"/"list of manifest entries" pairs.  This variable
;;   is set by `set-current-manifest-maybe!' when it is needed.

;;; Code:

(use-modules
 (ice-9 vlist)
 (ice-9 match)
 (srfi srfi-1)
 (srfi srfi-11)
 (srfi srfi-19)
 (srfi srfi-26)
 (guix)
 (guix packages)
 (guix profiles)
 (guix licenses)
 (guix utils)
 (guix ui)
 (guix scripts package)
 (gnu packages))

(define-syntax-rule (first-or-false lst)
  (and (not (null? lst))
       (first lst)))

(define full-name->name+version package-name->name+version)
(define (name+version->full-name name version)
  (string-append name "-" version))

(define* (make-package-specification name #:optional version output)
  (let ((full-name (if version
                       (name+version->full-name name version)
                       name)))
    (if output
        (string-append full-name ":" output)
        full-name)))

(define name+version->key cons)
(define key->name+version car+cdr)

(define %current-manifest #f)
(define %current-manifest-entries-table #f)

(define %packages
  (fold-packages (lambda (pkg res)
                   (vhash-consq (object-address pkg) pkg res))
                 vlist-null))

(define %package-table
  (let ((table (make-hash-table (vlist-length %packages))))
    (vlist-for-each
     (lambda (elem)
       (match elem
         ((address . pkg)
          (let* ((key (name+version->key (package-name pkg)
                                         (package-version pkg)))
                 (ref (hash-ref table key)))
            (hash-set! table key
                       (if ref (cons pkg ref) (list pkg)))))))
     %packages)
    table))

;; FIXME get rid of this function!
(define (set-current-manifest-maybe! profile)
  (define (manifest-entries->hash-table entries)
    (let ((entries-table (make-hash-table (length entries))))
      (for-each (lambda (entry)
                  (let* ((key (name+version->key
                               (manifest-entry-name entry)
                               (manifest-entry-version entry)))
                         (ref (hash-ref entries-table key)))
                    (hash-set! entries-table key
                               (if ref (cons entry ref) (list entry)))))
                entries)
      entries-table))

  (when profile
    (let ((manifest (profile-manifest profile)))
      (unless (and (manifest? %current-manifest)
                   (equal? manifest %current-manifest))
        (set! %current-manifest manifest)
        (set! %current-manifest-entries-table
              (manifest-entries->hash-table
               (manifest-entries manifest)))))))

(define (manifest-entries-by-name+version name version)
  (or (hash-ref %current-manifest-entries-table
                (name+version->key name version))
      '()))

(define (packages-by-name+version name version)
  (or (hash-ref %package-table
                (name+version->key name version))
      '()))

(define (packages-by-full-name full-name)
  (call-with-values
      (lambda () (full-name->name+version full-name))
    packages-by-name+version))

(define (package-by-address address)
  (and=> (vhash-assq address %packages)
         cdr))

(define (packages-by-id id)
  (if (integer? id)
      (let ((pkg (package-by-address id)))
        (if pkg (list pkg) '()))
      (packages-by-full-name id)))

(define (package-by-id id)
  (first-or-false (packages-by-id id)))

(define (newest-package-by-id id)
  (and=> (id->name+version id)
         (lambda (name)
           (first-or-false (find-best-packages-by-name name #f)))))

(define (id->name+version id)
  (if (integer? id)
      (and=> (package-by-address id)
             (lambda (pkg)
               (values (package-name pkg)
                       (package-version pkg))))
      (full-name->name+version id)))

(define (fold-manifest-entries proc init)
  "Fold over `%current-manifest-entries-table'.
Call (PROC NAME VERSION ENTRIES RESULT) for each element of the hash
table, using INIT as the initial value of RESULT."
  (hash-fold (lambda (key entries res)
               (let-values (((name version) (key->name+version key)))
                 (proc name version entries res)))
             init
             %current-manifest-entries-table))

(define (fold-object proc init obj)
  (fold proc init
        (if (list? obj) obj (list obj))))

(define* (object-transformer param-alist #:optional (params '()))
  "Return function for transforming an object into alist of parameters/values.

PARAM-ALIST is alist of available object parameters (symbols) and functions
returning values of these parameters.  Each function is called with object as
a single argument.

PARAMS is list of parameters from PARAM-ALIST that should be returned by a
resulting function.  If PARAMS is not specified or is an empty list, use all
available parameters.

Example:

  (let ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>))))
        (number->alist (object-transformer alist '(plus1 mul2))))
    (number->alist 8))
  =>
  ((plus1 . 9) (mul2 . 16))
"
  (let ((alist (let ((use-all-params (null? params)))
                 (filter-map (match-lambda
                              ((param . fun)
                               (and (or use-all-params
                                        (memq param params))
                                    (cons param fun)))
                              (_ #f))
                             param-alist))))
    (lambda (object)
      (map (match-lambda
            ((param . fun)
             (cons param (fun object))))
           alist))))

(define package-installed-param-alist
  (list
   (cons 'output       manifest-entry-output)
   (cons 'path         manifest-entry-item)
   (cons 'dependencies manifest-entry-dependencies)))

(define manifest-entry->installed-entry
  (object-transformer package-installed-param-alist))

(define (manifest-entries->installed-entries entries)
  (map manifest-entry->installed-entry entries))

(define (installed-entries-by-name+version name version)
  (manifest-entries->installed-entries
   (manifest-entries-by-name+version name version)))

(define (installed-entries-by-package package)
  (installed-entries-by-name+version (package-name package)
                                     (package-version package)))

(define (package-inputs-names inputs)
  "Return list of full names of the packages from package INPUTS."
  (filter-map (match-lambda
               ((_ (? package? package))
                (package-full-name package))
               (_ #f))
              inputs))

(define (package-license-names package)
  "Return list of license names of the PACKAGE."
  (fold-object (lambda (license res)
                 (if (license? license)
                     (cons (license-name license) res)
                     res))
               '()
               (package-license package)))

(define (package-unique? package)
  "Return #t if PACKAGE is a single package with such name/version."
  (null? (cdr (packages-by-name+version (package-name package)
                                        (package-version package)))))

(define package-param-alist
  (list
   (cons 'id                object-address)
   (cons 'name              package-name)
   (cons 'version           package-version)
   (cons 'license           package-license-names)
   (cons 'synopsis          package-synopsis)
   (cons 'description       package-description)
   (cons 'home-url          package-home-page)
   (cons 'outputs           package-outputs)
   (cons 'non-unique        (negate package-unique?))
   (cons 'inputs            (lambda (pkg) (package-inputs-names
                                      (package-inputs pkg))))
   (cons 'native-inputs     (lambda (pkg) (package-inputs-names
                                      (package-native-inputs pkg))))
   (cons 'propagated-inputs (lambda (pkg) (package-inputs-names
                                      (package-propagated-inputs pkg))))
   (cons 'location          (lambda (pkg) (location->string
                                      (package-location pkg))))
   (cons 'installed         installed-entries-by-package)))

(define (package-param package param)
  "Return the value of a PACKAGE PARAM."
  (define (accessor param)
    (and=> (assq param package-param-alist)
           cdr))
  (and=> (accessor param)
         (cut <> package)))

(define (matching-package-entries ->entry predicate)
  "Return list of package entries for the matching packages.
PREDICATE is called on each package."
  (fold-packages (lambda (pkg res)
                   (if (predicate pkg)
                       (cons (->entry pkg) res)
                       res))
                 '()))

(define (make-obsolete-package-entry name version entries)
  "Return package entry for an obsolete package with NAME and VERSION.
ENTRIES is a list of manifest entries used to get installed info."
  `((id        . ,(name+version->full-name name version))
    (name      . ,name)
    (version   . ,version)
    (outputs   . ,(map manifest-entry-output entries))
    (obsolete  . #t)
    (installed . ,(manifest-entries->installed-entries entries))))

(define (package-entries-by-name+version ->entry name version)
  "Return list of package entries for packages with NAME and VERSION."
  (let ((packages (packages-by-name+version name version)))
    (if (null? packages)
        (let ((entries (manifest-entries-by-name+version name version)))
          (if (null? entries)
              '()
              (list (make-obsolete-package-entry name version entries))))
        (map ->entry packages))))

(define (package-entries-by-spec profile ->entry spec)
  "Return list of package entries for packages with name specification SPEC."
  (set-current-manifest-maybe! profile)
  (let-values (((name version)
                (full-name->name+version spec)))
    (if version
        (package-entries-by-name+version ->entry name version)
        (matching-package-entries
         ->entry
         (lambda (pkg) (string=? name (package-name pkg)))))))

(define (package-entries-by-regexp profile ->entry regexp match-params)
  "Return list of package entries for packages matching REGEXP string.
MATCH-PARAMS is a list of parameters that REGEXP can match."
  (define (package-match? package regexp)
    (any (lambda (param)
           (let ((val (package-param package param)))
             (and (string? val) (regexp-exec regexp val))))
         match-params))

  (set-current-manifest-maybe! profile)
  (let ((re (make-regexp regexp regexp/icase)))
    (matching-package-entries ->entry (cut package-match? <> re))))

(define (package-entries-by-ids profile ->entry ids)
  "Return list of package entries for packages matching KEYS.
IDS may be an object-address, a full-name or a list of such elements."
  (set-current-manifest-maybe! profile)
  (fold-object
   (lambda (id res)
     (if (integer? id)
         (let ((pkg (package-by-address id)))
           (if pkg
               (cons (->entry pkg) res)
               res))
         (let ((entries (package-entries-by-spec #f ->entry id)))
           (if (null? entries)
               res
               (append res entries)))))
   '()
   ids))

(define (newest-available-package-entries profile ->entry)
  "Return list of package entries for the newest available packages."
  (set-current-manifest-maybe! profile)
  (vhash-fold (lambda (name elem res)
                (match elem
                  ((version newest pkgs ...)
                   (cons (->entry newest) res))))
              '()
              (find-newest-available-packages)))

(define (all-available-package-entries profile ->entry)
  "Return list of package entries for all available packages."
  (set-current-manifest-maybe! profile)
  (matching-package-entries ->entry (const #t)))

(define (manifest-package-entries ->entry)
  "Return list of package entries for the current manifest."
  (fold-manifest-entries
   (lambda (name version entries res)
     ;; We don't care about duplicates for the list of
     ;; installed packages, so just take any package (car)
     ;; matching name+version
     (cons (car (package-entries-by-name+version ->entry name version))
           res))
   '()))

(define (installed-package-entries profile ->entry)
  "Return list of package entries for all installed packages."
  (set-current-manifest-maybe! profile)
  (manifest-package-entries ->entry))

(define (generation-package-entries profile ->entry generation)
  "Return list of package entries for packages from GENERATION."
  (set-current-manifest-maybe!
   (generation-file-name profile generation))
  (manifest-package-entries ->entry))

(define (obsolete-package-entries profile _)
  "Return list of package entries for obsolete packages."
  (set-current-manifest-maybe! profile)
  (fold-manifest-entries
   (lambda (name version entries res)
     (let ((packages (packages-by-name+version name version)))
       (if (null? packages)
           (cons (make-obsolete-package-entry name version entries) res)
           res)))
   '()))


;;; Generation entries

(define (profile-generations profile)
  "Return list of generations for PROFILE."
  (let ((generations (generation-numbers profile)))
    (if (equal? generations '(0))
        '()
        generations)))

(define (generation-param-alist profile)
  "Return alist of generation parameters and functions for PROFILE."
  (list
   (cons 'id          identity)
   (cons 'number      identity)
   (cons 'prev-number (cut previous-generation-number profile <>))
   (cons 'path        (cut generation-file-name profile <>))
   (cons 'time        (lambda (gen)
                        (time-second (generation-time profile gen))))))

(define (matching-generation-entries profile ->entry predicate)
  "Return list of generation entries for the matching generations.
PREDICATE is called on each generation."
  (filter-map (lambda (gen)
                (and (predicate gen) (->entry gen)))
              (profile-generations profile)))

(define (last-generation-entries profile ->entry number)
  "Return list of last NUMBER generation entries.
If NUMBER is 0 or less, return all generation entries."
  (let ((generations (profile-generations profile))
        (number (if (<= number 0) +inf.0 number)))
    (map ->entry
         (if (> (length generations) number)
             (list-head  (reverse generations) number)
             generations))))

(define (all-generation-entries profile ->entry)
  "Return list of all generation entries."
  (last-generation-entries profile ->entry +inf.0))

(define (generation-entries-by-ids profile ->entry ids)
  "Return list of generation entries for generations matching IDS.
IDS is a list of generation numbers."
  (matching-generation-entries profile ->entry (cut memq <> ids)))


;;; Getting package/generation entries

(define %package-entries-functions
  (alist->vhash
   `((id               . ,package-entries-by-ids)
     (name             . ,package-entries-by-spec)
     (regexp           . ,package-entries-by-regexp)
     (all-available    . ,all-available-package-entries)
     (newest-available . ,newest-available-package-entries)
     (installed        . ,installed-package-entries)
     (obsolete         . ,obsolete-package-entries)
     (generation       . ,generation-package-entries))
   hashq))

(define %generation-entries-functions
  (alist->vhash
   `((id   . ,generation-entries-by-ids)
     (last . ,last-generation-entries)
     (all  . ,all-generation-entries))
   hashq))

(define (get-entries profile params entry-type search-type search-vals)
  "Return list of entries.
ENTRY-TYPE and SEARCH-TYPE define a search function that should be
applied to PARAMS and VALS."
  (let-values (((vhash ->entry)
                (case entry-type
                  ((package)
                   (values %package-entries-functions
                           (object-transformer
                            package-param-alist params)))
                  ((generation)
                   (values %generation-entries-functions
                           (object-transformer
                            (generation-param-alist profile) params)))
                  (else (format (current-error-port)
                                "Wrong entry type '~a'" entry-type)))))
    (match (vhash-assq search-type vhash)
      ((key . fun)
       (apply fun profile ->entry search-vals))
      (_ '()))))


;;; Actions

(define* (package->manifest-entry* package #:optional output)
  (and package
       (begin
         (check-package-freshness package)
         (package->manifest-entry package output))))

(define* (make-install-manifest-entries id #:optional output)
  (package->manifest-entry* (package-by-id id) output))

(define* (make-upgrade-manifest-entries id #:optional output)
  (package->manifest-entry* (newest-package-by-id id) output))

(define* (make-manifest-pattern id #:optional output)
  "Make manifest pattern from a package ID and OUTPUT."
  (let-values (((name version)
                (id->name+version id)))
    (and name version
         (manifest-pattern
          (name name)
          (version version)
          (output output)))))

(define (convert-action-pattern pattern proc)
  "Convert action PATTERN into a list of objects returned by PROC.
PROC is called: (PROC ID) or (PROC ID OUTPUT)."
  (match pattern
    ((id . outputs)
     (if (null? outputs)
         (let ((obj (proc id)))
           (if obj (list obj) '()))
         (filter-map (cut proc id <>)
                     outputs)))
    (_ '())))

(define (convert-action-patterns patterns proc)
  (append-map (cut convert-action-pattern <> proc)
              patterns))

(define* (process-package-actions
          profile #:key (install '()) (upgrade '()) (remove '())
          (use-substitutes? #t) dry-run?)
  "Perform package actions.

INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'.
Each pattern should have the following form:

  (ID . OUTPUTS)

ID is an object address or a full-name of a package.
OUTPUTS is a list of package outputs (may be an empty list)."
  (format #t "The process begins ...~%")
  (let* ((install (append
                   (convert-action-patterns
                    install make-install-manifest-entries)
                   (convert-action-patterns
                    upgrade make-upgrade-manifest-entries)))
         (remove (convert-action-patterns remove make-manifest-pattern))
         (transaction (manifest-transaction (install install)
                                            (remove remove)))
         (manifest (profile-manifest profile))
         (new-manifest (manifest-perform-transaction
                        manifest transaction)))
    (unless (and (null? install) (null? remove))
      (let* ((store (open-connection))
             (derivation (run-with-store
                          store (profile-derivation new-manifest)))
             (derivations (list derivation))
             (new-profile (derivation->output-path derivation)))
        (set-build-options store
                           #:use-substitutes? use-substitutes?)
        (manifest-show-transaction store manifest transaction
                                   #:dry-run? dry-run?)
        (show-what-to-build store derivations
                            #:use-substitutes? use-substitutes?
                            #:dry-run? dry-run?)
        (unless dry-run?
          (let ((name (generation-file-name
                       profile
                       (+ 1 (generation-number profile)))))
            (and (build-derivations store derivations)
                 (let* ((entries (manifest-entries new-manifest))
                        (count   (length entries)))
                   (switch-symlinks name new-profile)
                   (switch-symlinks profile name)
                   (format #t (N_ "~a package in profile~%"
                                  "~a packages in profile~%"
                                  count)
                           count)))))))))