From 536c3ee4e3741926c3791e04e025f5cab6aacf2b Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 3 Mar 2015 02:09:30 -0500
Subject: [PATCH] profiles: Produce a single-file CA certificate bundle.
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

* guix/profiles.scm (ca-certificate-bundle): New procedure.
  (profile-derivation): Add 'ca-certificate-bundle?' keyword argument.  If
  true (the default), add the result of 'ca-certificate-bundle' to 'inputs'.

Co-Authored-By: Ludovic Courtès <ludo@gnu.org>
---
 guix/profiles.scm | 91 ++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 78 insertions(+), 13 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index a0a259bd4e..5ceba25def 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -413,23 +414,87 @@ MANIFEST."
       (gexp->derivation "info-dir" build
                         #:modules '((guix build utils)))))
 
-(define* (profile-derivation manifest #:key (info-dir? #t))
+(define (ca-certificate-bundle manifest)
+  "Return a derivation that builds a single-file bundle containing the CA
+certificates in the /etc/ssl/certs sub-directories of the packages in
+MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
+  ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html>
+  ;; for a discussion.
+
+  (define glibc-utf8-locales                      ;lazy reference
+    (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
+
+  (define build
+    #~(begin
+        (use-modules (guix build utils)
+                     (rnrs io ports)
+                     (srfi srfi-1)
+                     (srfi srfi-26)
+                     (ice-9 ftw))
+
+        (define (pem-file? file)
+          (string-suffix? ".pem" file))
+
+        (define (ca-files top)
+          (let ((cert-dir (string-append top "/etc/ssl/certs")))
+            (map (cut string-append cert-dir "/" <>)
+                 (or (scandir cert-dir pem-file?) '()))))
+
+        (define (concatenate-files files result)
+          "Make RESULT the concatenation of all of FILES."
+          (define (dump file port)
+            (display (call-with-input-file file get-string-all)
+                     port)
+            (newline port))    ;required, see <https://bugs.debian.org/635570>
+
+          (call-with-output-file result
+            (lambda (port)
+              (for-each (cut dump <> port) files))))
+
+        ;; Some file names in the NSS certificates are UTF-8 encoded so
+        ;; install a UTF-8 locale.
+        (setenv "LOCPATH" (string-append #+glibc-utf8-locales "/lib/locale"))
+        (setlocale LC_ALL "en_US.UTF-8")
+
+        (let ((ca-files (append-map ca-files
+                                    '#$(manifest-inputs manifest)))
+              (result   (string-append #$output "/etc/ssl/certs")))
+          (mkdir-p result)
+          (concatenate-files ca-files
+                             (string-append result
+                                            "/ca-certificates.crt")))))
+
+  (gexp->derivation "ca-certificate-bundle" build
+                    #:modules '((guix build utils))
+                    #:local-build? #t))
+
+(define* (profile-derivation manifest
+                             #:key
+                             (info-dir? #t)
+                             (ca-certificate-bundle? #t))
   "Return a derivation that builds a profile (aka. 'user environment') with
-the given MANIFEST.  The profile includes a top-level Info 'dir' file, unless
-INFO-DIR? is #f."
+the given MANIFEST.  The profile includes a top-level Info 'dir' file unless
+INFO-DIR? is #f, and a single-file CA certificate bundle unless
+CA-CERTIFICATE-BUNDLE? is #f."
   (mlet %store-monad ((info-dir (if info-dir?
                                     (info-dir-file manifest)
-                                    (return #f))))
+                                    (return #f)))
+                      (ca-cert-bundle (if ca-certificate-bundle?
+                                          (ca-certificate-bundle manifest)
+                                          (return #f))))
     (define inputs
-      (if info-dir
-          ;; XXX: Here we use the tuple (INFO-DIR "out") just so that the list
-          ;; is unambiguous for the gexp code when MANIFEST has a single input
-          ;; denoted as a string (the pattern (DRV STRING) is normally
-          ;; interpreted in a gexp as "the STRING output of DRV".).  See
-          ;; <http://lists.gnu.org/archive/html/guix-devel/2014-12/msg00292.html>.
-          (cons (list info-dir "out")
-                (manifest-inputs manifest))
-          (manifest-inputs manifest)))
+      ;; XXX: Here we use tuples of the form (DIR "out") just so that the list
+      ;; is unambiguous for the gexp code when MANIFEST has a single input
+      ;; denoted as a string (the pattern (DRV STRING) is normally
+      ;; interpreted in a gexp as "the STRING output of DRV".).  See
+      ;; <http://lists.gnu.org/archive/html/guix-devel/2014-12/msg00292.html>.
+      (append (if info-dir
+                  `((,info-dir "out"))
+                  '())
+              (if ca-cert-bundle
+                  `((,ca-cert-bundle "out"))
+                  '())
+              (manifest-inputs manifest)))
 
     (define builder
       #~(begin
-- 
2.20.1