bug#29654: Manual database index.db embeds timestamps

[Ludovic Courtès]

Hi Ruud,

Ruud van Asseldonk <address@hidden> skribis:

> The manual database file index.db embeds mtimes of the files it refers
> to, making it not reproducible. This is an issue for building
> reproducible profiles (as produced by `guix pack` for example).
>
> The number that are not reproducible can be seen with `accessdb
> index.db`, which will output something like
>
> $version$ -> "2.5.0"
> acme-client -> "- 1 1 1512941854 498178709 B - - gz secure ACME client"
>
> And when built again on a clean installation:
>
> $version$ -> "2.5.0"
> acme-client -> "- 1 1 1512942998 296814690 B - - gz secure ACME client"

Good catch.

I was already motivated to create the database directly from Scheme
(‘man-db’ is quite slow), so that gave me an additional excuse.  ;-)

The attached patch does that.  The timestamps are always set to zero.

You can check for reproducibility by doing:

  guix package -p foo -i bar baz
  guix build --check /gnu/store/…-manual-database.drv

where the .drv is the one shown in the ‘guix package’ output.

Unfortunately, this is not fully deterministic: when running --check
several times in a row, I occasionally get different results.  I suspect
GDBM’s output is not fully deterministic.

Thoughts?

Ludo’.

>From 9da89cbdda484c106ff2706f09089d87bdf88a45 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
Date: Fri, 15 Dec 2017 22:08:34 +0100
Subject: [PATCH 1/2] gnu: guile-gdbm-ffi: Default to Guile 2.2.

* gnu/packages/guile.scm (guile-gdbm-ffi)[inputs]: Switch to GUILE-2.2.
(guile2.0-gdbm-ffi, guile2.2-gdbm-ffi): New variables.
---
 gnu/packages/guile.scm | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm
index c0fda71ea..887e360a3 100644
--- a/gnu/packages/guile.scm
+++ b/gnu/packages/guile.scm
@@ -1097,7 +1097,7 @@ inspired by the SCSH regular expression system.")
            ;; compile to the destination
            (compile-file gdbm.scm-dest gdbm.go-dest)))))
     (inputs
-     `(("guile" ,guile-2.0)))
+     `(("guile" ,guile-2.2)))
     (propagated-inputs
      `(("gdbm" ,gdbm)))
     (home-page "https://github.com/ijp/guile-gdbm";)
@@ -1107,8 +1107,11 @@ inspired by the SCSH regular expression system.")
 Guile's foreign function interface.")
     (license license:gpl3+)))
 
+(define-public guile2.0-gdbm-ffi
+  (package-for-guile-2.0 guile-gdbm-ffi))
+
 (define-public guile2.2-gdbm-ffi
-  (package-for-guile-2.2 guile-gdbm-ffi))
+  (deprecated-package "guile2.2-gdbm-ffi" guile-gdbm-ffi))
 
 (define-public guile-sqlite3
   (let ((commit "607721fe1174a299e45d457acacf94eefb964071"))
-- 
2.15.1

>From d37d0640e073ea18a07254e93f75940fc0f74f74 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
Date: Fri, 15 Dec 2017 22:16:18 +0100
Subject: [PATCH 2/2] DRAFT profiles: Use (guix man-db) to create the manual
 database.

DRAFT: Database is not entirely bit-reproducible.

* guix/man-db.scm: New file.
* Makefile.am (MODULES_NOT_COMPILED): Add it.
* guix/profiles.scm (manual-database): Rewrite to use (guix man-db).
---
 Makefile.am       |   3 +-
 guix/man-db.scm   | 184 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 guix/profiles.scm | 104 +++++++++++++-----------------
 3 files changed, 230 insertions(+), 61 deletions(-)
 create mode 100644 guix/man-db.scm

diff --git a/Makefile.am b/Makefile.am
index 85b9ab36d..fe1e685f3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -34,7 +34,8 @@ nodist_noinst_SCRIPTS =                               \
 
 # Modules that are not compiled but are installed nonetheless, such as
 # build-side modules with unusual dependencies.
-MODULES_NOT_COMPILED =
+MODULES_NOT_COMPILED =                         \
+  guix/man-db.scm
 
 include gnu/local.mk
 
diff --git a/guix/man-db.scm b/guix/man-db.scm
new file mode 100644
index 000000000..b42558b06
--- /dev/null
+++ b/guix/man-db.scm
@@ -0,0 +1,184 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <address@hidden>
+;;;
+;;; 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 (guix man-db)
+  #:use-module (guix zlib)
+  #:use-module ((guix build utils) #:select (find-files))
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:export (mandb-entry?
+            mandb-entry-file-name
+            mandb-entry-name
+            mandb-entry-section
+            mandb-entry-synopsis
+
+            mandb-entries
+            write-mandb-database))
+
+;;; Comment:
+;;;
+;;; Scan gzipped man pages and create a man-db database.  The database is
+;;; meant to be used by 'man -k KEYWORD'.
+;;;
+;;; The implementation here aims to be simpler than that of 'man-db', and to
+;;; produce deterministic output.  See <https://bugs.gnu.org/29654>.
+;;;
+;;; Code:
+
+;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co.
+(module-use! (current-module) (resolve-interface '(gdbm)))
+
+(define-record-type <mandb-entry>
+  (mandb-entry file-name name section synopsis)
+  mandb-entry?
+  (file-name mandb-entry-file-name)               ;e.g., "../abiword.1.gz"
+  (name      mandb-entry-name)                    ;e.g., "ABIWORD"
+  (section   mandb-entry-section)                 ;number
+  (synopsis  mandb-entry-synopsis))               ;string
+
+(define (mandb-entry<? entry1 entry2)
+  (match entry1
+    (($ <mandb-entry> file1 name1 section1)
+     (match entry2
+       (($ <mandb-entry> file2 name2 section2)
+        (or (< section1 section2)
+            (string<? (basename file1) (basename file2))))))))
+
+(define abbreviate-file-name
+  (let ((man-file-rx (make-regexp "(.+)\\.[0-9][a-z]?(\\.gz)?$")))
+    (lambda (file)
+      (match (regexp-exec man-file-rx (basename file))
+        (#f
+         (basename file))
+        (matches
+         (match:substring matches 1))))))
+
+(define (entry->string entry)
+  "Return the wire format for ENTRY as a string."
+  (match entry
+    (($ <mandb-entry> file name section synopsis)
+     (string-append (abbreviate-file-name file) "\t"
+                    (number->string section) "\t"
+                    (number->string section)
+
+                    ;; Timestamps, that we always set to the epoch.
+                    "\t0\t0"
+
+                    ;; XXX: Weird things.
+                    "\tB\t-\t-\tgz\t"
+
+                    synopsis "\x00"))))
+
+;; The man-db schema version we're compatible with.
+(define %version-key "$version$\x00")
+(define %version-value "2.5.0\x00")
+
+(define (write-mandb-database file entries)
+  "Write ENTRIES to FILE as a man-db database.  FILE is usually
+\".../index.db\", and is a GDBM database."
+  (let ((db (gdbm-open file GDBM_WRCREAT)))
+    (gdbm-set! db %version-key %version-value)
+
+    ;; Write ENTRIES in sorted order so we get deterministic output.
+    (for-each (lambda (entry)
+                (gdbm-set! db
+                           (string-append (mandb-entry-file-name entry)
+                                          "\x00")
+                           (entry->string entry)))
+              (sort entries mandb-entry<?))
+    (gdbm-close db)))
+
+(define (read-synopsis port)
+  "Read from PORT a man page synopsis."
+  (define (section? line)
+    ;; True if LINE starts with ".SH", ".PP", or so.
+    (string-prefix? "." (string-trim line)))
+
+  (define (extract-synopsis str)
+    (match (string-contains str "\\-")
+      (#f "")
+      (index
+       (string-map (match-lambda
+                     (#\newline #\space)
+                     (chr chr))
+                   (string-trim-both (string-drop str (+ 2 index)))))))
+
+  ;; Synopses look like "Command \- Do something.", possibly spanning several
+  ;; lines.
+  (let loop ((lines '()))
+    (match (read-line port 'concat)
+      ((? eof-object?)
+       (extract-synopsis (string-concatenate-reverse lines)))
+      ((? section?)
+       (extract-synopsis (string-concatenate-reverse lines)))
+      (line
+       (loop (cons line lines))))))
+
+(define* (man-page->entry file #:optional (resolve identity))
+  "Parse FILE, a gzipped man page, and return a <mandb-entry> for it."
+  (define (string->number* str)
+    (if (and (string-prefix? "\"" str)
+             (> (string-length str) 1)
+             (string-suffix? "\"" str))
+        (string->number (string-drop (string-drop-right str 1) 1))
+        (string->number str)))
+
+  (call-with-gzip-input-port (open-file file "r0")
+    (lambda (port)
+      (let loop ((name     #f)
+                 (section  #f)
+                 (synopsis #f))
+        (if (and name section synopsis)
+            (mandb-entry file name section synopsis)
+            (let ((line (read-line port)))
+              (if (eof-object? line)
+                  (mandb-entry file name (or section 0) (or synopsis ""))
+                  (match (string-tokenize line)
+                    ((".TH" name (= string->number* section) _ ...)
+                     (loop name section synopsis))
+                    ((".SH" (or "NAME" "\"NAME\""))
+                     (loop name section (read-synopsis port)))
+                    ((".so" link)
+                     (match (and=> (resolve link)
+                                   (cut man-page->entry <> resolve))
+                       (#f
+                        (loop name section synopsis))
+                       (alias
+                        (mandb-entry file
+                                     (mandb-entry-name alias)
+                                     (mandb-entry-section alias)
+                                     (mandb-entry-synopsis alias)))))
+                    (_
+                     (loop name section synopsis))))))))))
+
+(define (man-files directory)
+  "Return the list of man pages found under DIRECTORY, recursively."
+  (find-files directory "\\.[0-9][a-z]?(\\.gz)?$"))
+
+(define (mandb-entries directory)
+  "Return mandb entries for the man pages found under DIRECTORY, recursively."
+  (map (lambda (file)
+         (man-page->entry file
+                          (lambda (link)
+                            (let ((file (string-append directory "/" link
+                                                       ".gz")))
+                              (and (file-exists? file) file)))))
+       (man-files directory)))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index cedf9faa8..962b9074b 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -33,6 +33,7 @@
   #:use-module (guix derivations)
   #:use-module (guix search-paths)
   #:use-module (guix gexp)
+  #:use-module (guix modules)
   #:use-module (guix monads)
   #:use-module (guix store)
   #:use-module (guix sets)
@@ -1113,82 +1114,65 @@ files for the fonts of the @var{manifest} entries."
 (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 gdbm-ffi
+    (module-ref (resolve-interface '(gnu packages guile))
+                'guile-gdbm-ffi))
+
+  (define zlib
+    (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
+
+  (define config.scm
+    (scheme-file "config.scm"
+                 #~(begin
+                     (define-module (guix config)
+                       #:export (%libz))
+
+                     (define %libz
+                       #+(file-append zlib "/lib/libz")))))
+
+  (define modules
+    (cons `((guix config) => ,config.scm)
+          (delete '(guix config)
+                  (source-module-closure `((guix build utils)
+                                           (guix man-db))))))
 
   (define build
-    (with-imported-modules '((guix build utils))
+    (with-imported-modules modules
       #~(begin
-          (use-modules (guix build utils)
+          (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/"
+                                           (effective-version)))
+
+          (use-modules (guix man-db)
+                       (guix build utils)
                        (srfi srfi-1)
-                       (srfi srfi-19)
-                       (srfi srfi-26))
+                       (srfi srfi-19))
 
-          (define entries
-            (filter-map (lambda (directory)
+          (define (compute-entries)
+            (append-map (lambda (directory)
                           (let ((man (string-append directory "/share/man")))
-                            (and (directory-exists? man)
-                                 man)))
+                            (if (directory-exists? man)
+                                (mandb-entries 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))
+          (format #t "Creating manual page database...~%")
           (force-output)
-          (let* ((start-time (current-time))
-                 (exit-status (system* #+(file-append man-db "/bin/mandb")
-                                       "--quiet" "--create"
-                                       "-C" "man_db.conf"))
-                 (duration (time-difference (current-time) start-time)))
-            (format #t "done in ~,3f s~%"
+          (let* ((start    (current-time))
+                 (entries  (compute-entries))
+                 (_        (write-mandb-database (string-append man-directory
+                                                                "/index.db")
+                                                 entries))
+                 (duration (time-difference (current-time) start)))
+            (format #t "~a entries processed in ~,1f s~%"
+                    (length entries)
                     (+ (time-second duration)
                        (* (time-nanosecond duration) (expt 10 -9))))
-            (force-output)
-            (zero? exit-status)))))
+            (force-output)))))
 
   (gexp->derivation "manual-database" build
                     #:local-build? #t))
-- 
2.15.1