unofficial mirror of guix-devel@gnu.org 
 help / color / mirror / code / Atom feed
blob 31da773a536de80ffbf18ce8f565b9b3b37a85e8 44147 bytes (raw)
name: guix/scripts/package.scm 	 # note: path name is non-authoritative(*)

   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
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
 
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.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 scripts package)
  #:use-module (guix ui)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix monads)
  #:use-module (guix utils)
  #:use-module (guix config)
  #:use-module (guix scripts build)
  #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
  #:use-module ((guix ftp-client) #:select (ftp-open))
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (gnu packages)
  #:use-module ((gnu packages base) #:select (guile-final))
  #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
  #:use-module (guix gnu-maintenance)
  #:export (specification->package+output
            guix-package))

(define %store
  (make-parameter #f))

\f
;;;
;;; Profiles.
;;;

(define %user-profile-directory
  (and=> (getenv "HOME")
         (cut string-append <> "/.guix-profile")))

(define %profile-directory
  (string-append %state-directory "/profiles/"
                 (or (and=> (or (getenv "USER")
                                (getenv "LOGNAME"))
                            (cut string-append "per-user/" <>))
                     "default")))

(define %current-profile
  ;; Call it `guix-profile', not `profile', to allow Guix profiles to
  ;; coexist with Nix profiles.
  (string-append %profile-directory "/guix-profile"))

(define (canonicalize-profile profile)
  "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE.  Otherwise
return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile' as if
'-p' was omitted."                           ; see <http://bugs.gnu.org/17939>
  (if (and %user-profile-directory
           (string=? (canonicalize-path (dirname profile))
                     (dirname %user-profile-directory))
           (string=? (basename profile) (basename %user-profile-directory)))
      %current-profile
      profile))

(define (link-to-empty-profile generation)
  "Link GENERATION, a string, to the empty profile."
  (let* ((drv  (run-with-store (%store)
                 (profile-derivation (manifest '()))))
         (prof (derivation->output-path drv "out")))
    (when (not (build-derivations (%store) (list drv)))
          (leave (_ "failed to build the empty profile~%")))

    (switch-symlinks generation prof)))

(define (switch-to-previous-generation profile)
  "Atomically switch PROFILE to the previous generation."
  (let* ((number              (generation-number profile))
         (previous-number     (previous-generation-number profile number))
         (previous-generation (generation-file-name profile previous-number)))
    (format #t (_ "switching from generation ~a to ~a~%")
            number previous-number)
    (switch-symlinks profile previous-generation)))

(define (roll-back profile)
  "Roll back to the previous generation of PROFILE."
  (let* ((number              (generation-number profile))
         (previous-number     (previous-generation-number profile number))
         (previous-generation (generation-file-name profile previous-number))
         (manifest            (string-append previous-generation "/manifest")))
    (cond ((not (file-exists? profile))                 ; invalid profile
           (leave (_ "profile '~a' does not exist~%")
                  profile))
          ((zero? number)                               ; empty profile
           (format (current-error-port)
                   (_ "nothing to do: already at the empty profile~%")))
          ((or (zero? previous-number)                  ; going to emptiness
               (not (file-exists? previous-generation)))
           (link-to-empty-profile previous-generation)
           (switch-to-previous-generation profile))
          (else
           (switch-to-previous-generation profile)))))  ; anything else

(define* (matching-generations str #:optional (profile %current-profile)
                               #:key (duration-relation <=))
  "Return the list of available generations matching a pattern in STR.  See
'string->generations' and 'string->duration' for the list of valid patterns.
When STR is a duration pattern, return all the generations whose ctime has
DURATION-RELATION with the current time."
  (define (valid-generations lst)
    (define (valid-generation? n)
      (any (cut = n <>) (generation-numbers profile)))

    (fold-right (lambda (x acc)
                  (if (valid-generation? x)
                      (cons x acc)
                      acc))
                '()
                lst))

  (define (filter-generations generations)
    (match generations
      (() '())
      (('>= n)
       (drop-while (cut > n <>)
                   (generation-numbers profile)))
      (('<= n)
       (valid-generations (iota n 1)))
      ((lst ..1)
       (valid-generations lst))
      (_ #f)))

  (define (filter-by-duration duration)
    (define (time-at-midnight time)
      ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
      ;; hours to zeros.
      (let ((d (time-utc->date time)))
         (date->time-utc
          (make-date 0 0 0 0
                     (date-day d) (date-month d)
                     (date-year d) (date-zone-offset d)))))

    (define generation-ctime-alist
      (map (lambda (number)
             (cons number
                   (time-second
                    (time-at-midnight
                     (generation-time profile number)))))
           (generation-numbers profile)))

    (match duration
      (#f #f)
      (res
       (let ((s (time-second
                 (subtract-duration (time-at-midnight (current-time))
                                    duration))))
         (delete #f (map (lambda (x)
                           (and (duration-relation s (cdr x))
                                (first x)))
                         generation-ctime-alist))))))

  (cond ((string->generations str)
         =>
         filter-generations)
        ((string->duration str)
         =>
         filter-by-duration)
        (else #f)))

(define (show-what-to-remove/install remove install dry-run?)
  "Given the manifest entries listed in REMOVE and INSTALL, display the
packages that will/would be installed and removed."
  ;; TODO: Report upgrades more clearly.
  (match remove
    ((($ <manifest-entry> name version output path _) ..1)
     (let ((len    (length name))
           (remove (map (cut format #f "   ~a-~a\t~a\t~a" <> <> <> <>)
                        name version output path)))
       (if dry-run?
           (format (current-error-port)
                   (N_ "The following package would be removed:~%~{~a~%~}~%"
                       "The following packages would be removed:~%~{~a~%~}~%"
                       len)
                   remove)
           (format (current-error-port)
                   (N_ "The following package will be removed:~%~{~a~%~}~%"
                       "The following packages will be removed:~%~{~a~%~}~%"
                       len)
                   remove))))
    (_ #f))
  (match install
    ((($ <manifest-entry> name version output item _) ..1)
     (let ((len     (length name))
           (install (map (lambda (name version output item)
                           (format #f "   ~a-~a\t~a\t~a" name version output
                                   (if (package? item)
                                       (package-output (%store) item output)
                                       item)))
                         name version output item)))
       (if dry-run?
           (format (current-error-port)
                   (N_ "The following package would be installed:~%~{~a~%~}~%"
                       "The following packages would be installed:~%~{~a~%~}~%"
                       len)
                   install)
           (format (current-error-port)
                   (N_ "The following package will be installed:~%~{~a~%~}~%"
                       "The following packages will be installed:~%~{~a~%~}~%"
                       len)
                   install))))
    (_ #f)))

\f
;;;
;;; Package specifications.
;;;

(define (find-packages-by-description rx)
  "Return the list of packages whose name, synopsis, or description matches
RX."
  (define (same-location? p1 p2)
    ;; Compare locations of two packages.
    (equal? (package-location p1) (package-location p2)))

  (delete-duplicates
   (sort
    (fold-packages (lambda (package result)
                     (define matches?
                       (cut regexp-exec rx <>))

                     (if (or (matches? (package-name package))
                             (and=> (package-synopsis package)
                                    (compose matches? P_))
                             (and=> (package-description package)
                                    (compose matches? P_)))
                         (cons package result)
                         result))
                   '())
    (lambda (p1 p2)
      (string<? (package-name p1)
                (package-name p2))))
   same-location?))

(define %sigint-prompt
  ;; The prompt to jump to upon SIGINT.
  (make-prompt-tag "interruptible"))

(define (call-with-sigint-handler thunk handler)
  "Call THUNK and return its value.  Upon SIGINT, call HANDLER with the signal
number in the context of the continuation of the call to this function, and
return its return value."
  (call-with-prompt %sigint-prompt
                    (lambda ()
                      (sigaction SIGINT
                        (lambda (signum)
                          (sigaction SIGINT SIG_DFL)
                          (abort-to-prompt %sigint-prompt signum)))
                      (dynamic-wind
                        (const #t)
                        thunk
                        (cut sigaction SIGINT SIG_DFL)))
                    (lambda (k signum)
                      (handler signum))))

(define-syntax-rule (waiting exp fmt rest ...)
  "Display the given message while EXP is being evaluated."
  (let* ((message (format #f fmt rest ...))
         (blank   (make-string (string-length message) #\space)))
    (display message (current-error-port))
    (force-output (current-error-port))
    (call-with-sigint-handler
     (lambda ()
       (dynamic-wind
         (const #f)
         (lambda () exp)
         (lambda ()
           ;; Clear the line.
           (display #\cr (current-error-port))
           (display blank (current-error-port))
           (display #\cr (current-error-port))
           (force-output (current-error-port)))))
     (lambda (signum)
       (format (current-error-port) "  interrupted by signal ~a~%" SIGINT)
       #f))))

(define-syntax-rule (leave-on-EPIPE exp ...)
  "Run EXP... in a context when EPIPE errors are caught and lead to 'exit'
with successful exit code.  This is useful when writing to the standard output
may lead to EPIPE, because the standard output is piped through 'head' or
similar."
  (catch 'system-error
    (lambda ()
      exp ...)
    (lambda args
      ;; We really have to exit this brutally, otherwise Guile eventually
      ;; attempts to flush all the ports, leading to an uncaught EPIPE down
      ;; the path.
      (if (= EPIPE (system-error-errno args))
          (primitive-_exit 0)
          (apply throw args)))))

(define* (specification->package+output spec #:optional (output "out"))
  "Return the package and output specified by SPEC, or #f and #f; SPEC may
optionally contain a version number and an output name, as in these examples:

  guile
  guile-2.0.9
  guile:debug
  guile-2.0.9:debug

If SPEC does not specify a version number, return the preferred newest
version; if SPEC does not specify an output, return OUTPUT."
  (define (ensure-output p sub-drv)
    (if (member sub-drv (package-outputs p))
        sub-drv
        (leave (_ "package `~a' lacks output `~a'~%")
               (package-full-name p)
               sub-drv)))

  (let-values (((name version sub-drv)
                (package-specification->name+version+output spec output)))
    (match (find-best-packages-by-name name version)
      ((p)
       (values p (ensure-output p sub-drv)))
      ((p p* ...)
       (warning (_ "ambiguous package specification `~a'~%")
                spec)
       (warning (_ "choosing ~a from ~a~%")
                (package-full-name p)
                (location->string (package-location p)))
       (values p (ensure-output p sub-drv)))
      (()
       (leave (_ "~a: package not found~%") spec)))))

(define (upgradeable? name current-version current-path)
  "Return #t if there's a version of package NAME newer than CURRENT-VERSION,
or if the newest available version is equal to CURRENT-VERSION but would have
an output path different than CURRENT-PATH."
  (match (vhash-assoc name (find-newest-available-packages))
    ((_ candidate-version pkg . rest)
     (case (version-compare candidate-version current-version)
       ((>) #t)
       ((<) #f)
       ((=) (let ((candidate-path (derivation->output-path
                                   (package-derivation (%store) pkg))))
              (not (string=? current-path candidate-path))))))
    (#f #f)))

(define ftp-open*
  ;; Memoizing version of `ftp-open'.  The goal is to avoid initiating a new
  ;; FTP connection for each package, esp. since most of them are to the same
  ;; server.  This has a noticeable impact when doing "guix upgrade -u".
  (memoize ftp-open))

(define (check-package-freshness package)
  "Check whether PACKAGE has a newer version available upstream, and report
it."
  ;; TODO: Automatically inject the upstream version when desired.

  (catch #t
    (lambda ()
      (when (false-if-exception (gnu-package? package))
        (let ((name      (package-name package))
              (full-name (package-full-name package)))
          (match (waiting (latest-release name
                                          #:ftp-open ftp-open*
                                          #:ftp-close (const #f))
                          (_ "looking for the latest release of GNU ~a...") name)
            ((latest-version . _)
             (when (version>? latest-version full-name)
               (format (current-error-port)
                       (_ "~a: note: using ~a \
but ~a is available upstream~%")
                       (location->string (package-location package))
                       full-name latest-version)))
            (_ #t)))))
    (lambda (key . args)
      ;; Silently ignore networking errors rather than preventing
      ;; installation.
      (case key
        ((getaddrinfo-error ftp-error) #f)
        (else (apply throw key args))))))

\f
;;;
;;; Search paths.
;;;

(define* (search-path-environment-variables entries profile
                                            #:optional (getenv getenv))
  "Return environment variable definitions that may be needed for the use of
ENTRIES, a list of manifest entries, in PROFILE.  Use GETENV to determine the
current settings and report only settings not already effective."

  ;; Prefer ~/.guix-profile to the real profile directory name.
  (let ((profile (if (and %user-profile-directory
                          (false-if-exception
                           (string=? (readlink %user-profile-directory)
                                     profile)))
                     %user-profile-directory
                     profile)))

    ;; The search path info is not stored in the manifest.  Thus, we infer the
    ;; search paths from same-named packages found in the distro.

    (define manifest-entry->package
      (match-lambda
       (($ <manifest-entry> name version)
        ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name';
        ;; the former traverses the module tree only once and then allows for
        ;; efficient access via a vhash.
        (match (or (find-best-packages-by-name name version)
                   (find-best-packages-by-name name #f))
          ((p _ ...) p)
          (_ #f)))))

    (define search-path-definition
      (match-lambda
       (($ <search-path-specification> variable directories separator)
        (let ((values      (or (and=> (getenv variable)
                                      (cut string-tokenize* <> separator))
                               '()))
              (directories (filter file-exists?
                                   (map (cut string-append profile
                                             "/" <>)
                                        directories))))
          (if (every (cut member <> values) directories)
              #f
              (format #f "export ~a=\"~a\""
                      variable
                      (string-join directories separator)))))))

    (let* ((packages     (filter-map manifest-entry->package entries))
           (search-paths (delete-duplicates
                          (append-map package-native-search-paths
                                      packages))))
      (filter-map search-path-definition search-paths))))

(define (display-search-paths entries profile)
  "Display the search path environment variables that may need to be set for
ENTRIES, a list of manifest entries, in the context of PROFILE."
  (let ((settings (search-path-environment-variables entries profile)))
    (unless (null? settings)
      (format #t (_ "The following environment variable definitions may be needed:~%"))
      (format #t "~{   ~a~%~}" settings))))

\f
;;;
;;; Command-line options.
;;;

(define %default-options
  ;; Alist of default option values.
  `((profile . ,%current-profile)
    (max-silent-time . 3600)
    (verbosity . 0)
    (substitutes? . #t)))

(define (show-help)
  (display (_ "Usage: guix package [OPTION]... PACKAGES...
Install, remove, or upgrade PACKAGES in a single transaction.\n"))
  (display (_ "
  -i, --install=PACKAGE  install PACKAGE"))
  (display (_ "
  -e, --install-from-expression=EXP
                         install the package EXP evaluates to"))
  (display (_ "
  -r, --remove=PACKAGE   remove PACKAGE"))
  (display (_ "
  -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
  (display (_ "
      --roll-back        roll back to the previous generation"))
  (display (_ "
      --search-paths     display needed environment variable definitions"))
  (display (_ "
  -l, --list-generations[=PATTERN]
                         list generations matching PATTERN"))
  (display (_ "
  -d, --delete-generations[=PATTERN]
                         delete generations matching PATTERN"))
  (display (_ "
  -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
  (newline)
  (display (_ "
      --bootstrap        use the bootstrap Guile to build the profile"))
  (display (_ "
      --verbose          produce verbose output"))
  (newline)
  (display (_ "
  -s, --search=REGEXP    search in synopsis and description using REGEXP"))
  (display (_ "
  -I, --list-installed[=REGEXP]
                         list installed packages matching REGEXP"))
  (display (_ "
  -A, --list-available[=REGEXP]
                         list available packages matching REGEXP"))
  (display (_ "
  --show=PACKAGE         show details about PACKAGE"))
  (newline)
  (show-build-options-help)
  (newline)
  (display (_ "
  -h, --help             display this help and exit"))
  (display (_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %options
  ;; Specification of the command-line options.
  (cons* (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix package")))

         (option '(#\i "install") #f #t
                 (lambda (opt name arg result arg-handler)
                   (let arg-handler ((arg arg) (result result))
                     (values (if arg
                                 (alist-cons 'install arg result)
                                 result)
                             arg-handler))))
         (option '(#\e "install-from-expression") #t #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'install (read/eval-package-expression arg)
                                       result)
                           #f)))
         (option '(#\r "remove") #f #t
                 (lambda (opt name arg result arg-handler)
                   (let arg-handler ((arg arg) (result result))
                     (values (if arg
                                 (alist-cons 'remove arg result)
                                 result)
                             arg-handler))))
         (option '(#\u "upgrade") #f #t
                 (lambda (opt name arg result arg-handler)
                   (let arg-handler ((arg arg) (result result))
                     (values (alist-cons 'upgrade arg
                                         ;; Delete any prior "upgrade all"
                                         ;; command, or else "--upgrade gcc"
                                         ;; would upgrade everything.
                                         (delete '(upgrade . #f) result))
                             arg-handler))))
         (option '("roll-back") #f #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'roll-back? #t result)
                           #f)))
         (option '(#\l "list-generations") #f #t
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query list-generations ,(or arg ""))
                                 result)
                           #f)))
         (option '(#\d "delete-generations") #f #t
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'delete-generations (or arg "")
                                       result)
                           #f)))
         (option '("search-paths") #f #f
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query search-paths) result)
                           #f)))
         (option '(#\p "profile") #t #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'profile (canonicalize-profile arg)
                                       (alist-delete 'profile result))
                           #f)))
         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'dry-run? #t result)
                           #f)))
         (option '("bootstrap") #f #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'bootstrap? #t result)
                           #f)))
         (option '("verbose") #f #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'verbose? #t result)
                           #f)))
         (option '(#\s "search") #t #f
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query search ,(or arg ""))
                                 result)
                           #f)))
         (option '(#\I "list-installed") #f #t
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query list-installed ,(or arg ""))
                                 result)
                           #f)))
         (option '(#\A "list-available") #f #t
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query list-available ,(or arg ""))
                                 result)
                           #f)))
         (option '("show") #t #t
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query show ,arg)
                                 result)
                           #f)))

         %standard-build-options))

(define (options->installable opts manifest)
  "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
return the new list of manifest entries."
  (define (deduplicate deps)
    ;; Remove duplicate entries from DEPS, a list of propagated inputs, where
    ;; each input is a name/path tuple.
    (define (same? d1 d2)
      (match d1
        ((_ p1)
         (match d2
           ((_ p2) (eq? p1 p2))
           (_      #f)))
        ((_ p1 out1)
         (match d2
           ((_ p2 out2)
            (and (string=? out1 out2)
                 (eq? p1 p2)))
           (_ #f)))))

    (delete-duplicates deps same?))

  (define (package->manifest-entry* package output)
    (check-package-freshness package)
    ;; When given a package via `-e', install the first of its
    ;; outputs (XXX).
    (package->manifest-entry package output))

  (define upgrade-regexps
    (filter-map (match-lambda
                 (('upgrade . regexp)
                  (make-regexp (or regexp "")))
                 (_ #f))
                opts))

  (define packages-to-upgrade
    (match upgrade-regexps
      (()
       '())
      ((_ ...)
       (let ((newest (find-newest-available-packages)))
         (filter-map (match-lambda
                      (($ <manifest-entry> name version output path _)
                       (and (any (cut regexp-exec <> name)
                                 upgrade-regexps)
                            (upgradeable? name version path)
                            (let ((output (or output "out")))
                              (call-with-values
                                  (lambda ()
                                    (specification->package+output name output))
                                list))))
                      (_ #f))
                     (manifest-entries manifest))))))

  (define to-upgrade
    (map (match-lambda
          ((package output)
           (package->manifest-entry* package output)))
         packages-to-upgrade))

  (define packages-to-install
    (filter-map (match-lambda
                 (('install . (? package? p))
                  (list p "out"))
                 (('install . (? string? spec))
                  (and (not (store-path? spec))
                       (let-values (((package output)
                                     (specification->package+output spec)))
                         (and package (list package output)))))
                 (_ #f))
                opts))

  (define to-install
    (append (map (match-lambda
                  ((package output)
                   (package->manifest-entry* package output)))
                 packages-to-install)
            (filter-map (match-lambda
                         (('install . (? package?))
                          #f)
                         (('install . (? store-path? path))
                          (let-values (((name version)
                                        (package-name->name+version
                                         (store-path-package-name path))))
                            (manifest-entry
                             (name name)
                             (version version)
                             (output #f)
                             (item path))))
                         (_ #f))
                        opts)))

  (append to-upgrade to-install))

(define (options->removable options manifest)
  "Given options, return the list of manifest patterns of packages to be
removed from MANIFEST."
  (filter-map (match-lambda
               (('remove . spec)
                (call-with-values
                    (lambda ()
                      (package-specification->name+version+output spec))
                  (lambda (name version output)
                    (manifest-pattern
                      (name name)
                      (version version)
                      (output output)))))
               (_ #f))
              options))

(define (maybe-register-gc-root store profile)
  "Register PROFILE as a GC root, unless it doesn't need it."
  (unless (string=? profile %current-profile)
    (add-indirect-root store (canonicalize-path profile))))

(define (readlink* file)
  "Call 'readlink' until the result is not a symlink."
  (catch 'system-error
    (lambda ()
      (readlink* (readlink file)))
    (lambda args
      (if (= EINVAL (system-error-errno args))
          file
          (apply throw args)))))

\f
;;;
;;; Entry point.
;;;

(define (guix-package . args)
  (define (parse-options)
    ;; Return the alist of option values.
    (args-fold* args %options
                (lambda (opt name arg result arg-handler)
                  (leave (_ "~A: unrecognized option~%") name))
                (lambda (arg result arg-handler)
                  (if arg-handler
                      (arg-handler arg result)
                      (leave (_ "~A: extraneous argument~%") arg)))
                %default-options
                #f))

  (define (guile-missing?)
    ;; Return #t if %GUILE-FOR-BUILD is not available yet.
    (let ((out (derivation->output-path (%guile-for-build))))
      (not (valid-path? (%store) out))))

  (define (ensure-default-profile)
    ;; Ensure the default profile symlink and directory exist and are
    ;; writable.

    (define (rtfm)
      (format (current-error-port)
              (_ "Try \"info '(guix) Invoking guix package'\" for \
more information.~%"))
      (exit 1))

    ;; Create ~/.guix-profile if it doesn't exist yet.
    (when (and %user-profile-directory
               %current-profile
               (not (false-if-exception
                     (lstat %user-profile-directory))))
      (symlink %current-profile %user-profile-directory))

    (let ((s (stat %profile-directory #f)))
      ;; Attempt to create /…/profiles/per-user/$USER if needed.
      (unless (and s (eq? 'directory (stat:type s)))
        (catch 'system-error
          (lambda ()
            (mkdir-p %profile-directory))
          (lambda args
            ;; Often, we cannot create %PROFILE-DIRECTORY because its
            ;; parent directory is root-owned and we're running
            ;; unprivileged.
            (format (current-error-port)
                    (_ "error: while creating directory `~a': ~a~%")
                    %profile-directory
                    (strerror (system-error-errno args)))
            (format (current-error-port)
                    (_ "Please create the `~a' directory, with you as the owner.~%")
                    %profile-directory)
            (rtfm))))

      ;; Bail out if it's not owned by the user.
      (unless (or (not s) (= (stat:uid s) (getuid)))
        (format (current-error-port)
                (_ "error: directory `~a' is not owned by you~%")
                %profile-directory)
        (format (current-error-port)
                (_ "Please change the owner of `~a' to user ~s.~%")
                %profile-directory (or (getenv "USER")
                                       (getenv "LOGNAME")
                                       (getuid)))
        (rtfm))))

  (define (process-actions opts)
    ;; Process any install/remove/upgrade action from OPTS.

    (define dry-run? (assoc-ref opts 'dry-run?))
    (define verbose? (assoc-ref opts 'verbose?))
    (define profile  (assoc-ref opts 'profile))

    (define (same-package? entry name output)
      (match entry
        (($ <manifest-entry> entry-name _ entry-output _ ...)
         (and (equal? name entry-name)
              (equal? output entry-output)))))

    (define current-generation-number
      (generation-number profile))

    (define (display-and-delete number)
      (let ((generation (generation-file-name profile number)))
        (unless (zero? number)
          (format #t (_ "deleting ~a~%") generation)
          (delete-file generation))))

    (define (delete-generation number)
      (let* ((previous-number (previous-generation-number profile number))
             (previous-generation
              (generation-file-name profile previous-number)))
        (cond ((zero? number))  ; do not delete generation 0
              ((and (= number current-generation-number)
                    (not (file-exists? previous-generation)))
               (link-to-empty-profile previous-generation)
               (switch-to-previous-generation profile)
               (display-and-delete number))
              ((= number current-generation-number)
               (roll-back profile)
               (display-and-delete number))
              (else
               (display-and-delete number)))))

    ;; First roll back if asked to.
    (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?))
           (begin
             (roll-back profile)
             (process-actions (alist-delete 'roll-back? opts))))
          ((and (assoc-ref opts 'delete-generations)
                (not dry-run?))
           (filter-map
            (match-lambda
             (('delete-generations . pattern)
              (cond ((not (file-exists? profile)) ; XXX: race condition
                     (leave (_ "profile '~a' does not exist~%")
                            profile))
                    ((string-null? pattern)
                     (let ((numbers (generation-numbers profile)))
                       (if (equal? numbers '(0))
                           (exit 0)
                           (for-each display-and-delete
                                     (delete current-generation-number
                                             numbers)))))
                    ;; Do not delete the zeroth generation.
                    ((equal? 0 (string->number pattern))
                     (exit 0))

                    ;; If PATTERN is a duration, match generations that are
                    ;; older than the specified duration.
                    ((matching-generations pattern profile
                                           #:duration-relation >)
                     =>
                     (lambda (numbers)
                       (if (null-list? numbers)
                           (exit 1)
                           (for-each delete-generation numbers))))
                    (else
                     (leave (_ "invalid syntax: ~a~%")
                            pattern)))

              (process-actions
               (alist-delete 'delete-generations opts)))
             (_ #f))
            opts))
          (else
           (let* ((manifest (profile-manifest profile))
                  (install  (options->installable opts manifest))
                  (remove   (options->removable opts manifest))
                  (entries
                   (append install
                           (fold (lambda (package result)
                                   (match package
                                     (($ <manifest-entry> name _ out _ ...)
                                      (filter (negate
                                               (cut same-package? <>
                                                    name out))
                                              result))))
                                 (manifest-entries
                                  (manifest-remove manifest remove))
                                 install)))
                  (new      (make-manifest entries)))

             (when (equal? profile %current-profile)
               (ensure-default-profile))

             (unless (and (null? install) (null? remove))
               (let* ((prof-drv (run-with-store (%store)
                                  (profile-derivation new)))
                      (prof     (derivation->output-path prof-drv))
                      (remove   (manifest-matching-entries manifest remove)))
                 (show-what-to-remove/install remove install dry-run?)
                 (show-what-to-build (%store) (list prof-drv)
                                     #:use-substitutes?
                                     (assoc-ref opts 'substitutes?)
                                     #:dry-run? dry-run?)

                 (cond
                  (dry-run? #t)
                  ((and (file-exists? profile)
                        (and=> (readlink* profile) (cut string=? prof <>)))
                   (format (current-error-port) (_ "nothing to be done~%")))
                  (else
                   (let* ((number (generation-number profile))

                          ;; Always use NUMBER + 1 for the new profile,
                          ;; possibly overwriting a "previous future
                          ;; generation".
                          (name   (generation-file-name profile
                                                        (+ 1 number))))
                     (and (build-derivations (%store) (list prof-drv))
                          (let ((count (length entries)))
                            (switch-symlinks name prof)
                            (switch-symlinks profile name)
                            (maybe-register-gc-root (%store) profile)
                            (format #t (N_ "~a package in profile~%"
                                           "~a packages in profile~%"
                                           count)
                                    count)
                            (display-search-paths entries
                                                  profile))))))))))))

  (define (process-query opts)
    ;; Process any query specified by OPTS.  Return #t when a query was
    ;; actually processed, #f otherwise.
    (let ((profile  (assoc-ref opts 'profile)))
      (match (assoc-ref opts 'query)
        (('list-generations pattern)
         (define (list-generation number)
           (unless (zero? number)
             (let ((header (format #f (_ "Generation ~a\t~a") number
                                   (date->string
                                    (time-utc->date
                                     (generation-time profile number))
                                    "~b ~d ~Y ~T")))
                   (current (generation-number profile)))
               (if (= number current)
                   (format #t (_ "~a\t(current)~%") header)
                   (format #t "~a~%" header)))
             (for-each (match-lambda
                        (($ <manifest-entry> name version output location _)
                         (format #t "  ~a\t~a\t~a\t~a~%"
                                 name version output location)))

                       ;; Show most recently installed packages last.
                       (reverse
                        (manifest-entries
                         (profile-manifest
                          (generation-file-name profile number)))))
             (newline)))

         (cond ((not (file-exists? profile)) ; XXX: race condition
                (leave (_ "profile '~a' does not exist~%")
                       profile))
               ((string-null? pattern)
                (let ((numbers (generation-numbers profile)))
                  (leave-on-EPIPE
                   (if (equal? numbers '(0))
                       (exit 0)
                       (for-each list-generation numbers)))))
               ((matching-generations pattern profile)
                =>
                (lambda (numbers)
                  (if (null-list? numbers)
                      (exit 1)
                      (leave-on-EPIPE
                       (for-each list-generation numbers)))))
               (else
                (leave (_ "invalid syntax: ~a~%")
                       pattern)))
         #t)

        (('list-installed regexp)
         (let* ((regexp    (and regexp (make-regexp regexp)))
                (manifest  (profile-manifest profile))
                (installed (manifest-entries manifest)))
           (leave-on-EPIPE
            (for-each (match-lambda
                       (($ <manifest-entry> name version output path _)
                        (when (or (not regexp)
                                  (regexp-exec regexp name))
                          (format #t "~a\t~a\t~a\t~a~%"
                                  name (or version "?") output path))))

                      ;; Show most recently installed packages last.
                      (reverse installed)))
           #t))

        (('list-available regexp)
         (let* ((regexp    (and regexp (make-regexp regexp)))
                (available (fold-packages
                            (lambda (p r)
                              (let ((n (package-name p)))
                                (if regexp
                                    (if (regexp-exec regexp n)
                                        (cons p r)
                                        r)
                                    (cons p r))))
                            '())))
           (leave-on-EPIPE
            (for-each (lambda (p)
                        (format #t "~a\t~a\t~a\t~a~%"
                                (package-name p)
                                (package-version p)
                                (string-join (package-outputs p) ",")
                                (location->string (package-location p))))
                      (sort available
                            (lambda (p1 p2)
                              (string<? (package-name p1)
                                        (package-name p2))))))
           #t))

        (('search regexp)
         (let ((regexp (make-regexp regexp regexp/icase)))
           (leave-on-EPIPE
            (for-each (cute package->recutils <> (current-output-port))
                      (find-packages-by-description regexp)))
           #t))

        (('show requested-name)
         (let-values (((name version)
                       (package-name->name+version requested-name)))
           (leave-on-EPIPE
            (for-each (cute package->recutils <> (current-output-port))
                      (find-packages-by-name name version)))
           #t))

        (('search-paths)
         (let* ((manifest (profile-manifest profile))
                (entries  (manifest-entries manifest))
                (packages (map manifest-entry-name entries))
                (settings (search-path-environment-variables entries profile
                                                             (const #f))))
           (format #t "~{~a~%~}" settings)
           #t))

        (_ #f))))

  (let ((opts (parse-options)))
    (or (process-query opts)
        (with-error-handling
          (parameterize ((%store (open-connection)))
            (set-build-options-from-command-line (%store) opts)

            (parameterize ((%guile-for-build
                            (package-derivation (%store)
                                                (if (assoc-ref opts 'bootstrap?)
                                                    %bootstrap-guile
                                                    guile-final))))
              (process-actions opts)))))))

debug log:

solving 31da773 ...
found 31da773 in https://git.savannah.gnu.org/cgit/guix.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).