;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; 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 . (define-module (test-packages) #:use-module (guix tests) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix grafts) #:use-module ((guix gex
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Nikita <nikita@n0.is>
;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Raghav Gururajan <rg@raghavgururajan.name>
;;; Copyright © 2024 Carlo Zancanaro <carlo@zancanaro.id.au>
;;; Copyright © 2024 W. Kosior <koszko@koszko.org>
;;; Additions and modifications by W. Kosior are additionally
;;; dual-licensed under the Creative Commons Zero v1.0.
;;;
;;; 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 (gnu services certbot)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services mcron)
  #:use-module (gnu services web)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages tls)
  #:use-module (guix i18n)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (certbot-sans-nginx-service-type
            certbot-service-type
            certbot-configuration
            certbot-configuration?
            certificate-configuration))

;;; Commentary:
;;;
;;; Automatically obtaining TLS certificates from Let's Encrypt.
;;;
;;; Code:


(define-record-type* <certificate-configuration>
  certificate-configuration make-certificate-configuration
  certificate-configuration?
  (name                certificate-configuration-name
                       (default #f))
  (domains             certificate-configuration-domains
                       (default '()))
  (challenge           certificate-configuration-challenge
                       (default #f))
  (csr                 certificate-configuration-csr
                       (default #f))
  (authentication-hook certificate-authentication-hook
                       (default #f))
  (cleanup-hook        certificate-cleanup-hook
                       (default #f))
  (deploy-hook         certificate-configuration-deploy-hook
                       (default #f))
  (start-self-signed?  certificate-configuration-start-self-signed?
                       (default #t))
  (key-read-group      certificate-configuration-key-read-group
                       (default #f)))

(define-record-type* <certbot-configuration>
  certbot-configuration make-certbot-configuration
  certbot-configuration?
  (package             certbot-configuration-package
                       (default certbot))
  (webroot             certbot-configuration-webroot
                       (default "/var/www"))
  (certificates        certbot-configuration-certificates
                       (default '()))
  (email               certbot-configuration-email
                       (default #f))
  (server              certbot-configuration-server
                       (default #f))
  (rsa-key-size        certbot-configuration-rsa-key-size
                       (default #f))
  (default-location    certbot-configuration-default-location
                       (default
                         (nginx-location-configuration
                          (uri "/")
                          (body
                           (list "return 301 https://$host$request_uri;")))))
  (service-reload      certbot-configuration-service-reload
                       (default '(nginx)))
  (service-requirement certbot-configuration-service-requirement
                       (default '(nginx))))

(define (certbot-deploy-hook name deploy-hook-script reload-service-names
                             key-read-group)
  "Returns a gexp which creates symlinks for privkey.pem and fullchain.pem
from /etc/certs/NAME to /etc/letsenctypt/live/NAME.  If DEPLOY-HOOK-SCRIPT is
not #f then it is run after the symlinks have been created.  This wrapping is
necessary for certificates with start-self-signed? set to #t, as it will
overwrite the initial self-signed certificates upon the first successful
deploy."
  (program-file
   (string-append name "-deploy-hook")
   (with-imported-modules '((gnu services herd)
                            (guix build utils))
     #~(begin
         (use-modules (gnu services herd)
                      (guix build utils))
         #$(set-key-access-gexp
            (string-append "/etc/letsencrypt/live/" name "/privkey.pem")
            key-read-group)

         (mkdir-p #$(string-append "/etc/certs/" name))
         (chmod #$(string-append "/etc/certs/" name) #o755)

         ;; Create new symlinks
         (symlink #$(string-append
                     "/etc/letsencrypt/live/" name "/privkey.pem")
                  #$(string-append "/etc/certs/" name "/privkey.pem.new"))
         (symlink #$(string-append
                     "/etc/letsencrypt/live/" name "/fullchain.pem")
                  #$(string-append "/etc/certs/" name "/fullchain.pem.new"))

         ;; Rename over the top of the old ones, just in case they were the
         ;; original self-signed certificates.
         (rename-file #$(string-append "/etc/certs/" name "/privkey.pem.new")
                      #$(string-append "/etc/certs/" name "/privkey.pem"))
         (rename-file #$(string-append "/etc/certs/" name "/fullchain.pem.new")
                      #$(string-append "/etc/certs/" name "/fullchain.pem"))

         ;; With the new certificates in place, tell nginx/apache/whatever to
         ;; reload them.
         (for-each (lambda (service)
                     (with-shepherd-action service ('reload) result result))
                   '#$reload-service-names)

         #$@(if deploy-hook-script
                (list #~(invoke #$deploy-hook-script))
                '())))))

(define certbot-command
  (match-lambda
    (($ <certbot-configuration> package webroot certificates email
                                server rsa-key-size default-location
                                service-reload)
     (let* ((certbot (file-append package "/bin/certbot"))
            (rsa-key-size (and rsa-key-size (number->string rsa-key-size)))
            (commands
             (map
              (match-lambda
                (($ <certificate-configuration> custom-name domains challenge
                                                csr authentication-hook
                                                cleanup-hook deploy-hook
                                                start-self-signed?
                                                key-read-group)
                 (let ((name (or custom-name (car domains))))
                   (if challenge
                     (append
                      (list name certbot "certonly" "-n" "--agree-tos"
                            "--manual"
                            (string-append "--preferred-challenges=" challenge)
                            "--cert-name" name
                            "--manual-public-ip-logging-ok"
                            "-d" (string-join domains ","))
                      (if csr `("--csr" ,csr) '())
                      (if email
                          `("--email" ,email)
                          '("--register-unsafely-without-email"))
                      (if server `("--server" ,server) '())
                      (if rsa-key-size `("--rsa-key-size" ,rsa-key-size) '())
                      (if authentication-hook
                          `("--manual-auth-hook" ,authentication-hook)
                          '())
                      (if cleanup-hook `("--manual-cleanup-hook" ,cleanup-hook) '())
                      (list "--deploy-hook"
                            (certbot-deploy-hook name deploy-hook
                                                 service-reload
                                                 key-read-group)))
                     (append
                      (list name certbot "certonly" "-n" "--agree-tos"
                            "--webroot" "-w" webroot
                            "--cert-name" name
                            "-d" (string-join domains ","))
                      (if csr `("--csr" ,csr) '())
                      (if email
                          `("--email" ,email)
                          '("--register-unsafely-without-email"))
                      (if server `("--server" ,server) '())
                      (if rsa-key-size `("--rsa-key-size" ,rsa-key-size) '())
                      (list "--deploy-hook"
                            (certbot-deploy-hook name deploy-hook
                                                 service-reload
                                                 key-read-group)))))))
              certificates)))
       (program-file
        "certbot-command"
        #~(begin
            (use-modules (ice-9 match)
                         (ice-9 textual-ports))

            (define (log format-string . args)
              (apply format #t format-string args)
              (force-output))

            (define (file-contains? file string)
              (string-contains (call-with-input-file file
                                 get-string-all)
                               string))

            (define (connection-error?)
              ;; Certbot errors are always exit code 1, so we need to look at
              ;; the log file to see if there was a connection error.
              (file-contains? "/var/log/letsencrypt/letsencrypt.log"
                              "Failed to establish a new connection"))

            (let ((script-code 0))
              (for-each
               (match-lambda
                 ((name . command)
                  (log "Acquiring or renewing certificate: ~a~%" name)
                  (cond
                   ((zero? (status:exit-val (apply system* command)))
                    (log "Certificate successfully acquired: ~a~%" name))
                   ((connection-error?)
                    ;; If we have a connection error, then bail early with
                    ;; exit code 2. We don't expect this to resolve within the
                    ;; timespan of this script.
                    (log "Connection error - bailing out~%")
                    (exit 2))
                   (else
                    ;; If we have any other type of error, then continue but
                    ;; exit with a failing status code in the end.
                    (log "Error: ~a - continuing with other domains~%" name)
                    (set! script-code 1)))))
               '#$commands)
              (exit script-code))))))))

(define (certbot-renewal-jobs config)
  (list
   ;; Attempt to renew the certificates twice per day, at a random minute
   ;; within the hour.  See https://eff-certbot.readthedocs.io/.
   #~(job '(next-minute-from (next-hour '(0 12)) (list (random 60)))
          #$(certbot-command config))))

(define (certbot-renewal-one-shot config)
  (list
   ;; Renew certificates when the system first starts. This is a one-shot
   ;; service, because the mcron configuration will take care of running this
   ;; periodically. This is most useful the very first time the system starts,
   ;; to overwrite our self-signed certificates as soon as possible without
   ;; user intervention.
   (shepherd-service
    (provision '(renew-certbot-certificates))
    (requirement (certbot-configuration-service-requirement config))
    (one-shot? #t)
    (start #~(lambda _
               ;; This needs the network, but there's no reliable way to know
               ;; if the network is up other than trying. If we fail due to a
               ;; connection error we retry a number of times in the hope that
               ;; the network comes up soon.
               (let loop ((attempt 0))
                 (let ((code (status:exit-val
                              (system* #$(certbot-command config)))))
                   (cond
                    ((and (= code 2)      ; Exit code 2 means connection error
                          (< attempt 12)) ; Arbitrarily chosen max attempts
                     (sleep 10)           ; Arbitrarily chosen retry delay
                     (loop (1+ attempt)))
                    ((zero? code)
                     ;; Success!
                     #t)
                    (else
                     ;; Failure.
                     #f))))))
    (auto-start? #t)
    (documentation "Call certbot to renew certificates.")
    (actions (list (shepherd-configuration-action (certbot-command config)))))))

(define (set-key-access-gexp keyfile key-read-group)
  #~(let ((gid (or (and=> #$key-read-group (compose group:gid getgr))
                   0)))
      (chown #$keyfile -1 gid)
      (chmod #$keyfile #$(if key-read-group #o640 #o600))))

(define (generate-certificate-gexp certbot-cert-directory rsa-key-size)
  (match-lambda
    (($ <certificate-configuration> name (primary-domain other-domains ...)
                                    challenge
                                    csr authentication-hook
                                    cleanup-hook deploy-hook
                                    start-self-signed? key-read-group)
     (let* (;; Arbitrary default subject, with just the
            ;; right domain filled in. These values don't
            ;; have any real significance.
            (subject (string-append
                      "/C=US/ST=Oregon/L=Portland/O=Company Name/OU=Org/CN="
                      primary-domain))
            (alt-names (if (null? other-domains)
                           #f
                           (format #f "subjectAltName=~{DNS:~a~^,~}"
                                   other-domains)))
            (directory (string-append "/etc/certs/" (or name primary-domain)))
            (keyfile (string-append directory "/privkey.pem")))
       #~(begin
           (when (not (file-exists? #$directory))
             ;; We generate self-signed certificates in /etc/certs/{domain},
             ;; because certbot is very sensitive to its directory
             ;; structure. It refuses to write over the top of existing files,
             ;; so we need to use a directory outside of its control.
             ;;
             ;; These certificates are overwritten by the certbot deploy hook
             ;; the first time it successfully obtains a letsencrypt-signed
             ;; certificate.
             (mkdir-p #$directory)
             (chmod #$directory #o755)
             (invoke #$(file-append openssl "/bin/openssl")
                     "req" "-x509"
                     "-newkey" #$(format #f "rsa:~a" (or rsa-key-size "4096"))
                     "-keyout" #$keyfile
                     "-out" #$(string-append directory "/fullchain.pem")
                     "-sha256"
                     "-days" "1" ; Only one day, we expect certbot to run
                     "-nodes"
                     "-subj" #$subject
                     #$@(if alt-names
                            (list "-addext" alt-names)
                            (list))))
           #$(set-key-access-gexp keyfile key-read-group))))))

(define (certbot-activation config)
  (let* ((certbot-directory "/var/lib/certbot")
         (certbot-cert-directory "/etc/letsencrypt/live"))
    (match config
      (($ <certbot-configuration> package webroot certificates email
                                  server rsa-key-size default-location)
       (with-imported-modules '((guix build utils))
         #~(begin
             (use-modules (guix build utils))
             (mkdir-p #$webroot)
             (mkdir-p #$certbot-directory)
             (mkdir-p #$certbot-cert-directory)

             #$@(let ((rsa-key-size (and rsa-key-size
                                         (number->string rsa-key-size))))
                  (map (generate-certificate-gexp certbot-cert-directory
                                                  rsa-key-size)
                       (filter certificate-configuration-start-self-signed?
                               certificates)))))))))

(define certbot-nginx-server-configurations
  (match-lambda
    (($ <certbot-configuration> package webroot certificates email
                                server rsa-key-size default-location)
     (define (certificate->nginx-server certificate-configuration)
       (match-record certificate-configuration <certificate-configuration> 
         (domains challenge)
         (nginx-server-configuration
          (listen '("80" "[::]:80"))
          (ssl-certificate #f)
          (ssl-certificate-key #f)
          (server-name domains)
          (locations
           (filter identity
                   (append
                    (if challenge
                      '()
                      (list (nginx-location-configuration
                             (uri "/.well-known")
                             (body (list (list "root " webroot ";"))))))
                    (list default-location)))))))
     (map certificate->nginx-server certificates))))

(define certbot-sans-nginx-service-type
  (service-type (name 'certbot)
                (extensions
                 (list (service-extension profile-service-type
                                          (compose list certbot-configuration-package))
                       (service-extension activation-service-type
                                          certbot-activation)
                       (service-extension mcron-service-type
                                          certbot-renewal-jobs)
                       (service-extension shepherd-root-service-type
                                          certbot-renewal-one-shot)))
                (compose concatenate)
                (extend (lambda (config additional-certificates)
                          (certbot-configuration
                           (inherit config)
                           (certificates
                            (append
                             (certbot-configuration-certificates config)
                             additional-certificates)))))
                (description
                 "Automatically renew @url{https://letsencrypt.org, Let's
Encrypt} HTTPS certificates by periodically invoking @command{certbot}.")))

(define certbot-service-type
  (let ((base certbot-sans-nginx-service-type))
    (service-type (inherit base)
                  (extensions (cons (service-extension
                                     nginx-service-type
                                     certbot-nginx-server-configurations)
                                    (service-type-extensions base)))
                  (description
                   "Automatically renew @url{https://letsencrypt.org, Let's
Encrypt} HTTPS certificates by adjusting the nginx web server configuration
and periodically invoking @command{certbot}."))))
generated by cgit
kage (inherit (dummy-package "trivial-system-dependent-input")) (build-system trivial-build-system) (source #f) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out")) (bash (assoc-ref %build-inputs "bash"))) (zero? (system* bash "-c" (format #f "echo hello > ~a" out)))))) (inputs `(("bash" ,(search-bootstrap-binary "bash" (%current-system))))))) (d (package-derivation %store p))) (and (build-derivations %store (list d)) (let ((p (pk 'drv d (derivation->output-path d)))) (eq? 'hello (call-with-input-file p read)))))) (test-assert "trivial with #:allowed-references" (let* ((p (package (inherit (dummy-package "trivial")) (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:allowed-references (,%bootstrap-guile) #:builder (begin (mkdir %output) ;; The reference to itself isn't allowed so building it ;; should fail. (symlink %output (string-append %output "/self"))))))) (d (package-derivation %store p))) (guard (c ((nix-protocol-error? c) #t)) (build-derivations %store (list d)) #f))) (test-assert "search paths" (let* ((p (make-prompt-tag "return-search-paths")) (s (build-system (name 'raw) (description "Raw build system with direct store access") (lower (lambda* (name #:key source inputs system target #:allow-other-keys) (bag (name name) (system system) (target target) (build-inputs inputs) (build (lambda* (store name inputs #:key outputs system search-paths) search-paths))))))) (x (list (search-path-specification (variable "GUILE_LOAD_PATH") (files '("share/guile/site/2.0"))) (search-path-specification (variable "GUILE_LOAD_COMPILED_PATH") (files '("share/guile/site/2.0"))))) (a (package (inherit (dummy-package "guile")) (build-system s) (native-search-paths x))) (b (package (inherit (dummy-package "guile-foo")) (build-system s) (inputs `(("guile" ,a))))) (c (package (inherit (dummy-package "guile-bar")) (build-system s) (inputs `(("guile" ,a) ("guile-foo" ,b)))))) (let-syntax ((collect (syntax-rules () ((_ body ...) (call-with-prompt p (lambda () body ...) (lambda (k search-paths) search-paths)))))) (and (null? (collect (package-derivation %store a))) (equal? x (collect (package-derivation %store b))) (equal? x (collect (package-derivation %store c))))))) (test-assert "package-transitive-native-search-paths" (let* ((sp (lambda (name) (list (search-path-specification (variable name) (files '("foo/bar")))))) (p0 (dummy-package "p0" (native-search-paths (sp "PATH0")))) (p1 (dummy-package "p1" (native-search-paths (sp "PATH1")))) (p2 (dummy-package "p2" (native-search-paths (sp "PATH2")) (inputs `(("p0" ,p0))) (propagated-inputs `(("p1" ,p1))))) (p3 (dummy-package "p3" (native-search-paths (sp "PATH3")) (native-inputs `(("p0" ,p0))) (propagated-inputs `(("p2" ,p2)))))) (lset= string=? '("PATH1" "PATH2" "PATH3") (map search-path-specification-variable (package-transitive-native-search-paths p3))))) (test-assert "package-cross-derivation" (let ((drv (package-cross-derivation %store (dummy-package "p") "mips64el-linux-gnu"))) (and (derivation? drv) (file-exists? (derivation-file-name drv))))) (test-assert "package-cross-derivation, trivial-build-system" (let ((p (package (inherit (dummy-package "p")) (build-system trivial-build-system) (arguments '(#:builder (exit 1)))))) (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu"))) (derivation? drv)))) (test-assert "package-cross-derivation, no cross builder" (let* ((b (build-system (inherit trivial-build-system) (lower (const #f)))) (p (package (inherit (dummy-package "p")) (build-system b)))) (guard (c ((package-cross-build-system-error? c) (eq? (package-error-package c) p))) (package-cross-derivation %store p "mips64el-linux-gnu") #f))) ;; XXX: The next two tests can trigger builds when the distro defines ;; replacements on core packages, so they're disable for lack of a better ;; solution. ;; (test-equal "package-derivation, direct graft" ;; (package-derivation %store gnu-make #:graft? #f) ;; (let ((p (package (inherit coreutils) ;; (replacement gnu-make)))) ;; (package-derivation %store p #:graft? #t))) ;; (test-equal "package-cross-derivation, direct graft" ;; (package-cross-derivation %store gnu-make "mips64el-linux-gnu" ;; #:graft? #f) ;; (let ((p (package (inherit coreutils) ;; (replacement gnu-make)))) ;; (package-cross-derivation %store p "mips64el-linux-gnu" ;; #:graft? #t))) (test-assert "package-grafts, indirect grafts" (let* ((new (dummy-package "dep" (arguments '(#:implicit-inputs? #f)))) (dep (package (inherit new) (version "0.0"))) (dep* (package (inherit dep) (replacement new))) (dummy (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)) (inputs `(("dep" ,dep*)))))) (equal? (package-grafts %store dummy) (list (graft (origin (package-derivation %store dep)) (replacement (package-derivation %store new))))))) ;; XXX: This test would require building the cross toolchain just to see if it ;; needs grafting, which is obviously too expensive, and thus disabled. ;; ;; (test-assert "package-grafts, indirect grafts, cross" ;; (let* ((new (dummy-package "dep" ;; (arguments '(#:implicit-inputs? #f)))) ;; (dep (package (inherit new) (version "0.0"))) ;; (dep* (package (inherit dep) (replacement new))) ;; (dummy (dummy-package "dummy" ;; (arguments '(#:implicit-inputs? #f)) ;; (inputs `(("dep" ,dep*))))) ;; (target "mips64el-linux-gnu")) ;; ;; XXX: There might be additional grafts, for instance if the distro ;; ;; defines replacements for core packages like Perl. ;; (member (graft ;; (origin (package-cross-derivation %store dep target)) ;; (replacement ;; (package-cross-derivation %store new target))) ;; (package-grafts %store dummy #:target target)))) (test-assert "package-grafts, indirect grafts, propagated inputs" (let* ((new (dummy-package "dep" (arguments '(#:implicit-inputs? #f)))) (dep (package (inherit new) (version "0.0"))) (dep* (package (inherit dep) (replacement new))) (prop (dummy-package "propagated" (propagated-inputs `(("dep" ,dep*))) (arguments '(#:implicit-inputs? #f)))) (dummy (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)) (inputs `(("prop" ,prop)))))) (equal? (package-grafts %store dummy) (list (graft (origin (package-derivation %store dep)) (replacement (package-derivation %store new))))))) (test-assert "package-grafts, same replacement twice" (let* ((new (dummy-package "dep" (version "1") (arguments '(#:implicit-inputs? #f)))) (dep (package (inherit new) (version "0") (replacement new))) (p1 (dummy-package "intermediate1" (arguments '(#:implicit-inputs? #f)) (inputs `(("dep" ,dep))))) (p2 (dummy-package "intermediate2" (arguments '(#:implicit-inputs? #f)) ;; Here we copy DEP to have an equivalent package that is not ;; 'eq?' to DEP. This is similar to what happens with ;; 'package-with-explicit-inputs' & co. (inputs `(("dep" ,(package (inherit dep))))))) (p3 (dummy-package "final" (arguments '(#:implicit-inputs? #f)) (inputs `(("p1" ,p1) ("p2" ,p2)))))) (equal? (package-grafts %store p3) (list (graft (origin (package-derivation %store (package (inherit dep) (replacement #f)))) (replacement (package-derivation %store new))))))) (test-assert "replacement also grafted" ;; We build a DAG as below, where dotted arrows represent replacements and ;; solid arrows represent dependencies: ;; ;; P1 ·············> P1R ;; |\__________________. ;; v v ;; P2 ·············> P2R ;; | ;; v ;; P3 ;; ;; We want to make sure that: ;; grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R))) ;; where: ;; (A,B) is a graft to replace A by B ;; grafted(DRV,G) denoted DRV with graft G applied (let* ((p1r (dummy-package "P1" (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (call-with-output-file (string-append out "/replacement") (const #t))))))) (p1 (package (inherit p1r) (name "p1") (replacement p1r) (arguments `(#:guile ,%bootstrap-guile #:builder (mkdir (assoc-ref %outputs "out")))))) (p2r (dummy-package "P2" (build-system trivial-build-system) (inputs `(("p1" ,p1))) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p1") "p1") (call-with-output-file (string-append out "/replacement") (const #t))))))) (p2 (package (inherit p2r) (name "p2") (replacement p2r) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p1") "p1")))))) (p3 (dummy-package "p3" (build-system trivial-build-system) (inputs `(("p2" ,p2))) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p2") "p2"))))))) (lset= equal? (package-grafts %store p3) (list (graft (origin (package-derivation %store p1 #:graft? #f)) (replacement (package-derivation %store p1r))) (graft (origin (package-derivation %store p2 #:graft? #f)) (replacement (package-derivation %store p2r #:graft? #t))))))) ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to ;;; find out about their run-time dependencies, so this test is no longer ;;; applicable since it would trigger a full rebuild. ;; ;; (test-assert "package-derivation, indirect grafts" ;; (let* ((new (dummy-package "dep" ;; (arguments '(#:implicit-inputs? #f)))) ;; (dep (package (inherit new) (version "0.0"))) ;; (dep* (package (inherit dep) (replacement new))) ;; (dummy (dummy-package "dummy" ;; (arguments '(#:implicit-inputs? #f)) ;; (inputs `(("dep" ,dep*))))) ;; (guile (package-derivation %store (canonical-package guile-2.0) ;; #:graft? #f))) ;; (equal? (package-derivation %store dummy) ;; (graft-derivation %store ;; (package-derivation %store dummy #:graft? #f) ;; (package-grafts %store dummy) ;; ;; Use the same Guile as 'package-derivation'. ;; #:guile guile)))) (test-equal "package->bag" `("foo86-hurd" #f (,(package-source gnu-make)) (,(canonical-package glibc)) (,(canonical-package coreutils))) (let ((bag (package->bag gnu-make "foo86-hurd"))) (list (bag-system bag) (bag-target bag) (assoc-ref (bag-build-inputs bag) "source") (assoc-ref (bag-build-inputs bag) "libc") (assoc-ref (bag-build-inputs bag) "coreutils")))) (test-equal "package->bag, cross-compilation" `(,(%current-system) "foo86-hurd" (,(package-source gnu-make)) (,(canonical-package glibc)) (,(canonical-package coreutils))) (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd"))) (list (bag-system bag) (bag-target bag) (assoc-ref (bag-build-inputs bag) "source") (assoc-ref (bag-build-inputs bag) "libc") (assoc-ref (bag-build-inputs bag) "coreutils")))) (test-assert "package->bag, propagated inputs" (let* ((dep (dummy-package "dep")) (prop (dummy-package "prop" (propagated-inputs `(("dep" ,dep))))) (dummy (dummy-package "dummy" (inputs `(("prop" ,prop))))) (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f)))) (match (assoc "dep" inputs) (("dep" package) (eq? package dep))))) (test-assert "bag->derivation" (parameterize ((%graft? #f)) (let ((bag (package->bag gnu-make)) (drv (package-derivation %store gnu-make))) (parameterize ((%current-system "foox86-hurd")) ;should have no effect (equal? drv (bag->derivation %store bag)))))) (test-assert "bag->derivation, cross-compilation" (parameterize ((%graft? #f)) (let* ((target "mips64el-linux-gnu") (bag (package->bag gnu-make (%current-system) target)) (drv (package-cross-derivation %store gnu-make target))) (parameterize ((%current-system "foox86-hurd") ;should have no effect (%current-target-system "foo64-linux-gnu")) (equal? drv (bag->derivation %store bag)))))) (when (or (not (network-reachable?)) (shebang-too-long?)) (test-skip 1)) (test-assert "GNU Make, bootstrap" ;; GNU Make is the first program built during bootstrap; we choose it ;; here so that the test doesn't last for too long. (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0))) (and (package? gnu-make) (or (location? (package-location gnu-make)) (not (package-location gnu-make))) (let* ((drv (package-derivation %store gnu-make)) (out (derivation->output-path drv))) (and (build-derivations %store (list drv)) (file-exists? (string-append out "/bin/make"))))))) (test-equal "package-mapping" 42 (let* ((dep (dummy-package "chbouib" (native-inputs `(("x" ,grep))))) (p0 (dummy-package "example" (inputs `(("foo" ,coreutils) ("bar" ,grep) ("baz" ,dep))))) (transform (lambda (p) (package (inherit p) (source 42)))) (rewrite (package-mapping transform)) (p1 (rewrite p0))) (and (eq? p1 (rewrite p0)) (eqv? 42 (package-source p1)) (match (package-inputs p1) ((("foo" dep1) ("bar" dep2) ("baz" dep3)) (and (eq? dep1 (rewrite coreutils)) ;memoization (eq? dep2 (rewrite grep)) (eq? dep3 (rewrite dep)) (eqv? 42 (package-source dep1) (package-source dep2) (package-source dep3)) (match (package-native-inputs dep3) ((("x" dep)) (and (eq? dep (rewrite grep)) (package-source dep)))))))))) (test-assert "package-input-rewriting" (let* ((dep (dummy-package "chbouib" (native-inputs `(("x" ,grep))))) (p0 (dummy-package "example" (inputs `(("foo" ,coreutils) ("bar" ,grep) ("baz" ,dep))))) (rewrite (package-input-rewriting `((,coreutils . ,sed) (,grep . ,findutils)) (cut string-append "r-" <>))) (p1 (rewrite p0)) (p2 (rewrite p0))) (and (not (eq? p1 p0)) (eq? p1 p2) ;memoization (string=? "r-example" (package-name p1)) (match (package-inputs p1) ((("foo" dep1) ("bar" dep2) ("baz" dep3)) (and (eq? dep1 sed) (eq? dep2 findutils) (string=? (package-name dep3) "r-chbouib") (eq? dep3 (rewrite dep)) ;memoization (match (package-native-inputs dep3) ((("x" dep)) (eq? dep findutils))))))))) (test-eq "fold-packages" hello (fold-packages (lambda (p r) (if (string=? (package-name p) "hello") p r)) #f)) (test-assert "fold-packages, hidden package" ;; There are two public variables providing "guile@2.0" ('guile-final' in ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter ;; should show up. (match (fold-packages (lambda (p r) (if (and (string=? (package-name p) "guile") (string-prefix? "2.0" (package-version p))) (cons p r) r)) '()) ((one) (eq? one guile-2.0)))) (test-assert "find-packages-by-name" (match (find-packages-by-name "hello") (((? (cut eq? hello <>))) #t) (wrong (pk 'find-packages-by-name wrong #f)))) (test-assert "find-packages-by-name with version" (match (find-packages-by-name "hello" (package-version hello)) (((? (cut eq? hello <>))) #t) (wrong (pk 'find-packages-by-name wrong #f)))) (test-assert "--search-paths with pattern" ;; Make sure 'guix package --search-paths' correctly reports environment ;; variables when file patterns are used (in particular, it must follow ;; symlinks when looking for 'catalog.xml'.) To do that, we rely on the ;; libxml2 package specification, which contains such a definition. (let* ((p1 (package (name "foo") (version "0") (source #f) (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:modules ((guix build utils)) #:builder (begin (use-modules (guix build utils)) (let ((out (assoc-ref %outputs "out"))) (mkdir-p (string-append out "/xml/bar/baz")) (call-with-output-file (string-append out "/xml/bar/baz/catalog.xml") (lambda (port) (display "xml? wat?!" port))))))) (synopsis #f) (description #f) (home-page #f) (license #f))) (p2 (package ;; Provide a fake libxml2 to avoid building the real one. This ;; is OK because 'guix package' gets search path specifications ;; from the same-named package found in the distro. (name "libxml2") (version "0.0.0") (source #f) (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (mkdir (assoc-ref %outputs "out")))) (native-search-paths (package-native-search-paths libxml2)) (synopsis #f) (description #f) (home-page #f) (license #f))) (prof (run-with-store %store (profile-derivation (manifest (map package->manifest-entry (list p1 p2))) #:hooks '() #:locales? #f) #:guile-for-build (%guile-for-build)))) (build-derivations %store (list prof)) (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n" (regexp-quote (derivation->output-path prof))) (with-output-to-string (lambda () (guix-package "-p" (derivation->output-path prof) "--search-paths")))))) (test-assert "--search-paths with single-item search path" ;; Make sure 'guix package --search-paths' correctly reports environment ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their ;; separator, meaning that the first match wins. (let* ((p1 (dummy-package "foo" (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:modules ((guix build utils)) #:builder (begin (use-modules (guix build utils)) (let ((out (assoc-ref %outputs "out"))) (mkdir-p (string-append out "/etc/ssl/certs")) (call-with-output-file (string-append out "/etc/ssl/certs/ca-certificates.crt") (const #t)))))))) (p2 (package (inherit p1) (name "bar"))) (p3 (dummy-package "git" ;; Provide a fake Git to avoid building the real one. (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (mkdir (assoc-ref %outputs "out")))) (native-search-paths (package-native-search-paths git)))) (prof1 (run-with-store %store (profile-derivation (packages->manifest (list p1 p3)) #:hooks '() #:locales? #f) #:guile-for-build (%guile-for-build))) (prof2 (run-with-store %store (profile-derivation (packages->manifest (list p2 p3)) #:hooks '() #:locales? #f) #:guile-for-build (%guile-for-build)))) (build-derivations %store (list prof1 prof2)) (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt" (regexp-quote (derivation->output-path prof1))) (with-output-to-string (lambda () (guix-package "-p" (derivation->output-path prof1) "-p" (derivation->output-path prof2) "--search-paths")))))) (test-equal "specification->package when not found" 'quit (catch 'quit (lambda () ;; This should call 'leave', producing an error message. (specification->package "this-package-does-not-exist")) (lambda (key . args) key))) (test-end "packages") ;;; Local Variables: ;;; eval: (put 'dummy-package 'scheme-indent-function 1) ;;; End: