1 files changed, 79 insertions(+), 0 deletions(-)

M guix/profiles.scm

@@ 7,6 7,7 @@
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
+;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;


@@ 946,10 947,88 @@ files for the fonts of the @var{manifest} entries."
                     #:local-build? #t
                     #:substitutable? #f))
 
+(define (manual-database manifest)
+  "Return a derivation that builds the manual page database (\"mandb\") for
+the entries in MANIFEST."
+  (define man-db                                  ;lazy reference
+    (module-ref (resolve-interface '(gnu packages man)) 'man-db))
+
+  (define build
+    #~(begin
+        (use-modules (guix build utils)
+                     (srfi srfi-1)
+                     (srfi srfi-26))
+
+        (define entries
+          (filter-map (lambda (directory)
+                        (let ((man (string-append directory "/share/man")))
+                          (and (directory-exists? man)
+                               man)))
+                      '#$(manifest-inputs manifest)))
+
+        (define manpages-collection-dir
+          (string-append (getenv "PWD") "/manpages-collection"))
+
+        (define man-directory
+          (string-append #$output "/share/man"))
+
+        (define (get-manpage-tail-path manpage-path)
+          (let ((index (string-contains manpage-path "/share/man/")))
+            (unless index
+              (error "Manual path doesn't contain \"/share/man/\":"
+                     manpage-path))
+            (string-drop manpage-path (+ index (string-length "/share/man/")))))
+
+        (define (populate-manpages-collection-dir entries)
+          (let ((manpages (append-map (cut find-files <> #:stat stat) entries)))
+            (for-each (lambda (manpage)
+                        (let* ((dest-file (string-append
+                                           manpages-collection-dir "/"
+                                           (get-manpage-tail-path manpage))))
+                          (mkdir-p (dirname dest-file))
+                          (catch 'system-error
+                            (lambda ()
+                              (symlink manpage dest-file))
+                            (lambda args
+                              ;; Different packages may contain the same
+                              ;; manpage.  Simply ignore the symlink error.
+                              #t))))
+                      manpages)))
+
+        (mkdir-p manpages-collection-dir)
+        (populate-manpages-collection-dir entries)
+
+        ;; Create a mandb config file which contains a custom made
+        ;; manpath. The associated catpath is the location where the database
+        ;; gets generated.
+        (copy-file #+(file-append man-db "/etc/man_db.conf")
+                   "man_db.conf")
+        (substitute* "man_db.conf"
+          (("MANDB_MAP	/usr/man		/var/cache/man/fsstnd")
+           (string-append "MANDB_MAP " manpages-collection-dir " "
+                          man-directory)))
+
+        (mkdir-p man-directory)
+        (setenv "MANPATH" (string-join entries ":"))
+
+        (format #t "creating manual page database for ~a packages...~%"
+                (length entries))
+        (force-output)
+
+        (zero? (system* #+(file-append man-db "/bin/mandb")
+                        "--quiet" "--create"
+                        "-C" "man_db.conf"))))
+
+  (gexp->derivation "manual-database" build
+                    #:modules '((guix build utils)
+                                (srfi srfi-26))
+                    #:local-build? #t))
+
 (define %default-profile-hooks
   ;; This is the list of derivation-returning procedures that are called by
   ;; default when making a non-empty profile.
   (list info-dir-file
+        manual-database
         fonts-dir-file
         ghc-package-cache-file
         ca-certificate-bundle