~ruther/guix-cross-shells

ref: ebe06709e06e1e1b1279c3c099a42ef327210a59 guix-cross-shells/modules/cross-shells/build/set-search-paths.scm -rw-r--r-- 4.0 KiB
ebe06709 — Rutherther Initial commit 5 months ago 
                                                                                
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

(define-module (cross-shells build set-search-paths)
  #:use-module (guix search-paths)
  #:use-module (guix build gnu-build-system)
  #:use-module (guix build utils)
  #:use-module (guix build gremlin)
  #:use-module (guix elf)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 format)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs io ports)
  #:export (produce-/etc/profile
            produce-activation))

(define* (produce-/etc/profile #:key target inputs outputs native-inputs
                                 (search-paths '()) (native-search-paths '())
                                 #:allow-other-keys)
  (define input-directories
    ;; The "source" input can be a directory, but we don't want it for search
    ;; paths.  See <https://issues.guix.gnu.org/44924>.
    (match (alist-delete "source" inputs)
      (((_ . dir) ...)
       dir)))

  (define native-input-directories
    ;; When cross-compiling, the source appears in native-inputs rather than
    ;; inputs.
    (match (and=> native-inputs (cut alist-delete "source" <>))
      (((_ . dir) ...)
       dir)
      (#f                               ;not cross-compiling
       '())))

  (mkdir-p (string-append (assoc-ref outputs "out") "/etc"))
  (call-with-output-file (string-append (assoc-ref outputs "out") "/etc/profile")
    (lambda (port)
      ;; The use of $GUIX_PROFILE described below is not great.  Another
      ;; option would have been to use "$1" and have users run:
      ;;
      ;;   source ~/.guix-profile/etc/profile ~/.guix-profile
      ;;
      ;; However, when 'source' is used with no arguments, $1 refers to the
      ;; first positional parameter of the calling script, so we cannot rely
      ;; on it.
      (let* ((path  (search-path-as-list '("bin" "sbin")
                                         (append native-input-directories
                                                 (if target
                                                     '()
                                                     input-directories))))
             (value (list->search-path-as-string path ":")))
        (unless (string-null? value)
          (format port "export ~a=\"~a:$PATH\"~%" "PATH" value)))

      (for-each (match-lambda
                  ((env-var (files ...) separator type pattern)
                   (let* ((path  (search-path-as-list files input-directories
                                                      #:type type
                                                      #:pattern pattern))
                          (value (list->search-path-as-string path separator)))
                     (unless (string-null? value)
                       (format port "export ~a=\"~a~a$~a\"~%" env-var value separator env-var)))))
                search-paths)
      (for-each (match-lambda
                  ((env-var (files ...) separator type pattern)
                   (let* ((path  (search-path-as-list files native-input-directories
                                                      #:type type
                                                      #:pattern pattern))
                          (value (list->search-path-as-string path separator)))
                     (unless (string-null? value)
                       (format port "export ~a=\"~a~a$~a\"~%" env-var value separator env-var)))))
                native-search-paths))))


(define* (produce-activation #:key target inputs outputs native-inputs
                             #:allow-other-keys)
  (let* ((out (assoc-ref outputs "out"))
         (profile (string-append out "/etc/profile"))
         (bin (string-append out "/bin"))
         (activate (string-append bin "/activate")))
    (mkdir-p bin)
    (call-with-output-file activate
      (lambda (port)
        (format port "#!~a~%(source ~a && $SHELL)"
                (search-input-file inputs "/bin/bash")
                profile)))
    (chmod activate #o555)))