| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> |
| 3 | ;;; Copyright © 2022 Arjan Adriaanse <arjan@adriaan.se> |
| 4 | ;;; |
| 5 | ;;; This file is part of GNU Guix. |
| 6 | ;;; |
| 7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 8 | ;;; under the terms of the GNU General Public License as published by |
| 9 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 10 | ;;; your option) any later version. |
| 11 | ;;; |
| 12 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 15 | ;;; GNU General Public License for more details. |
| 16 | ;;; |
| 17 | ;;; You should have received a copy of the GNU General Public License |
| 18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 19 | |
| 20 | (define-module (test-home-import) |
| 21 | #:use-module (guix scripts home import) |
| 22 | #:use-module (guix utils) |
| 23 | #:use-module (guix build utils) |
| 24 | #:use-module (guix packages) |
| 25 | #:use-module (ice-9 match) |
| 26 | #:use-module ((guix read-print) #:select (blank?)) |
| 27 | #:use-module ((guix profiles) #:hide (manifest->code)) |
| 28 | #:use-module ((guix build syscalls) #:select (mkdtemp!)) |
| 29 | #:use-module ((guix scripts package) |
| 30 | #:select (manifest-entry-version-prefix)) |
| 31 | #:use-module (gnu packages) |
| 32 | #:use-module (srfi srfi-1) |
| 33 | #:use-module (srfi srfi-26) |
| 34 | #:use-module (srfi srfi-64)) |
| 35 | |
| 36 | ;; Test the (guix scripts home import) tools. |
| 37 | |
| 38 | (test-begin "home-import") |
| 39 | |
| 40 | ;; Example manifest entries. |
| 41 | |
| 42 | (define guile-2.0.9 |
| 43 | (manifest-entry |
| 44 | (name "guile") |
| 45 | (version "2.0.9") |
| 46 | (item "/gnu/store/..."))) |
| 47 | |
| 48 | (define glibc |
| 49 | (manifest-entry |
| 50 | (name "glibc") |
| 51 | (version "2.19") |
| 52 | (item "/gnu/store/..."))) |
| 53 | |
| 54 | (define gcc |
| 55 | (manifest-entry |
| 56 | (name "gcc") |
| 57 | (version "") |
| 58 | (output "lib") |
| 59 | (item "/gnu/store/..."))) |
| 60 | |
| 61 | ;; Helpers for checking and generating home environments. |
| 62 | |
| 63 | (define %destination-directory "/tmp/guix-config") |
| 64 | (mkdir-p %destination-directory) |
| 65 | |
| 66 | (define %temporary-home-directory (mkdtemp! "/tmp/guix-home-import.XXXXXX")) |
| 67 | |
| 68 | (define-syntax-rule (define-home-environment-matcher name pattern) |
| 69 | (define (name obj) |
| 70 | (match obj |
| 71 | (pattern #t) |
| 72 | (x (pk 'fail x #f))))) |
| 73 | |
| 74 | (define (create-temporary-home files-alist) |
| 75 | "Create a temporary home directory in '%temporary-home-directory'. |
| 76 | FILES-ALIST is an association list of files and the content of the |
| 77 | corresponding file." |
| 78 | (define (create-file file content) |
| 79 | (let ((absolute-path (string-append %temporary-home-directory "/" file))) |
| 80 | (unless (file-exists? absolute-path) |
| 81 | (mkdir-p (dirname absolute-path))) |
| 82 | (call-with-output-file absolute-path |
| 83 | (cut display content <>)))) |
| 84 | |
| 85 | (for-each (match-lambda |
| 86 | ((file . content) (create-file file content))) |
| 87 | files-alist)) |
| 88 | |
| 89 | (define (remove-recursively pred sexp) |
| 90 | "Like SRFI-1 'remove', but recurse within SEXP." |
| 91 | (let loop ((sexp sexp)) |
| 92 | (match sexp |
| 93 | ((lst ...) |
| 94 | (map loop (remove pred lst))) |
| 95 | (x x)))) |
| 96 | |
| 97 | (define (eval-test-with-home-environment files-alist manifest matcher) |
| 98 | (create-temporary-home files-alist) |
| 99 | (setenv "HOME" %temporary-home-directory) |
| 100 | (mkdir-p %temporary-home-directory) |
| 101 | (let* ((home-environment (manifest+configuration-files->code |
| 102 | manifest %destination-directory)) |
| 103 | (result (matcher (remove-recursively blank? home-environment)))) |
| 104 | (delete-file-recursively %temporary-home-directory) |
| 105 | result)) |
| 106 | |
| 107 | (define-home-environment-matcher match-home-environment-no-services |
| 108 | ('begin |
| 109 | ('use-modules |
| 110 | ('gnu 'home) |
| 111 | ('gnu 'packages) |
| 112 | ('gnu 'services)) |
| 113 | ('home-environment |
| 114 | ('packages |
| 115 | ('specifications->packages |
| 116 | ('list "guile@2.0.9" "gcc:lib" "glibc@2.19"))) |
| 117 | ('services |
| 118 | ('list))))) |
| 119 | |
| 120 | (define-home-environment-matcher match-home-environment-transformations |
| 121 | ('begin |
| 122 | ('use-modules |
| 123 | ('gnu 'home) |
| 124 | ('gnu 'packages) |
| 125 | ('gnu 'services) |
| 126 | ('guix 'transformations)) |
| 127 | |
| 128 | ('define transform ('options->transformation _)) |
| 129 | ('home-environment |
| 130 | ('packages |
| 131 | ('list (transform ('specification->package "guile@2.0.9")) |
| 132 | ('list ('specification->package "gcc") "lib") |
| 133 | ('specification->package "glibc@2.19"))) |
| 134 | ('services ('list))))) |
| 135 | |
| 136 | (define-home-environment-matcher match-home-environment-no-services-nor-packages |
| 137 | ('begin |
| 138 | ('use-modules |
| 139 | ('gnu 'home) |
| 140 | ('gnu 'packages) |
| 141 | ('gnu 'services)) |
| 142 | ('home-environment |
| 143 | ('packages |
| 144 | ('specifications->packages ('list))) |
| 145 | ('services |
| 146 | ('list))))) |
| 147 | |
| 148 | (define-home-environment-matcher match-home-environment-bash-service |
| 149 | ('begin |
| 150 | ('use-modules |
| 151 | ('gnu 'home) |
| 152 | ('gnu 'packages) |
| 153 | ('gnu 'services) |
| 154 | ('guix 'gexp) |
| 155 | ('gnu 'home 'services 'shells)) |
| 156 | ('home-environment |
| 157 | ('packages |
| 158 | ('specifications->packages ('list))) |
| 159 | ('services |
| 160 | ('list ('service |
| 161 | 'home-bash-service-type |
| 162 | ('home-bash-configuration |
| 163 | ('aliases ('quote ())) |
| 164 | ('bashrc |
| 165 | ('list ('local-file "/tmp/guix-config/.bashrc" |
| 166 | "bashrc")))))))))) |
| 167 | |
| 168 | (define-home-environment-matcher match-home-environment-bash-service-with-alias |
| 169 | ('begin |
| 170 | ('use-modules |
| 171 | ('gnu 'home) |
| 172 | ('gnu 'packages) |
| 173 | ('gnu 'services) |
| 174 | ('guix 'gexp) |
| 175 | ('gnu 'home 'services 'shells)) |
| 176 | ('home-environment |
| 177 | ('packages |
| 178 | ('specifications->packages ('list))) |
| 179 | ('services |
| 180 | ('list ('service |
| 181 | 'home-bash-service-type |
| 182 | ('home-bash-configuration |
| 183 | ('aliases |
| 184 | ('quote (("grep" . "grep --exclude-from=\"$HOME/.grep-exclude\"") |
| 185 | ("ls" . "ls -p")))) |
| 186 | ('bashrc |
| 187 | ('list ('local-file "/tmp/guix-config/.bashrc" |
| 188 | "bashrc")))))))))) |
| 189 | |
| 190 | |
| 191 | (test-assert "manifest->code: No services" |
| 192 | (eval-test-with-home-environment |
| 193 | '() |
| 194 | (make-manifest (list guile-2.0.9 gcc glibc)) |
| 195 | match-home-environment-no-services)) |
| 196 | |
| 197 | (test-assert "manifest->code: No services, package transformations" |
| 198 | (eval-test-with-home-environment |
| 199 | '() |
| 200 | (make-manifest (list (manifest-entry |
| 201 | (inherit guile-2.0.9) |
| 202 | (properties `((transformations |
| 203 | . ((foo . "bar")))))) |
| 204 | gcc glibc)) |
| 205 | match-home-environment-transformations)) |
| 206 | |
| 207 | (test-assert "manifest->code: No packages nor services" |
| 208 | (eval-test-with-home-environment |
| 209 | '() |
| 210 | (make-manifest '()) |
| 211 | match-home-environment-no-services-nor-packages)) |
| 212 | |
| 213 | (test-assert "manifest->code: Bash service" |
| 214 | (eval-test-with-home-environment |
| 215 | '((".bashrc" . "echo 'hello guix'")) |
| 216 | (make-manifest '()) |
| 217 | match-home-environment-bash-service)) |
| 218 | |
| 219 | (test-assert "manifest->code: Bash service with aliases" |
| 220 | (eval-test-with-home-environment |
| 221 | '((".bashrc" |
| 222 | . "# Aliases |
| 223 | alias ls=\"ls -p\"; alias grep='grep --exclude-from=\"$HOME/.grep-exclude\"'\n")) |
| 224 | (make-manifest '()) |
| 225 | match-home-environment-bash-service-with-alias)) |
| 226 | |
| 227 | (test-end "home-import") |