01/05: hydra: Add 'sync-disarchive-db.scm' program.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository maintenance.

commit fb83b3d8de189c6d6c33c4cdc2ebabf6eae1463e
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Oct 14 08:42:12 2021 +0200

    hydra: Add 'sync-disarchive-db.scm' program.
    
    * hydra/sync-disarchive-db.scm: New file.
---
 hydra/sync-disarchive-db.scm | 139 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 139 insertions(+)

diff --git a/hydra/sync-disarchive-db.scm b/hydra/sync-disarchive-db.scm
new file mode 100755
index 0000000..08cd4e0
--- /dev/null
+++ b/hydra/sync-disarchive-db.scm
@@ -0,0 +1,139 @@
+#!/usr/bin/env -S guix repl --
+!#
+;;; Synchronizing a copy of the Disarchive database.
+;;;
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This program 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.
+;;;
+;;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (guix)
+             (guix ci)
+             (guix diagnostics)
+             (guix i18n)
+             ((guix build utils) #:select (dump-port find-files mkdir-p))
+             (zlib)
+             (srfi srfi-1)
+             (ice-9 match))
+
+(define *cuirass-url*
+  (make-parameter "https://ci.guix.gnu.org";))
+
+(define (latest-disarchive-collection)
+  "Return the store file name of the latest Disarchive collection that was
+successfully built, or the store file name of its derivation."
+  (define-values (evaluation job)
+    (car+cdr
+     (any (lambda (evaluation)
+            (define id (evaluation-id evaluation))
+            (and (evaluation-complete? evaluation)
+                 (let ((job (find (lambda (job)
+                                    (string-prefix? "disarchive-collection"
+                                                    (job-name job)))
+                                  (evaluation-jobs (*cuirass-url*) id))))
+                   (and (eq? (job-status job) 'succeeded)
+                        (cons evaluation job)))))
+          (latest-evaluations (*cuirass-url*) 10 #:spec "disarchive"))))
+
+  (define build
+    (job-build (*cuirass-url*) job))
+
+  (info (G_ "found Disarchive build ~a for commit ~a~%")
+        (build-id build)
+        (match (evaluation-checkouts evaluation)
+          ((checkout _ ...)
+           (checkout-commit checkout))))
+
+  ;; Normally, BUILD has an associated "product", which gives us the store
+  ;; file name of the database, which can be passed right away to
+  ;; 'build-things' for substitution.  If not, we can always return the .drv
+  ;; file name, but substituting it and all its dependencies takes a loooong
+  ;; while because they're substituted one at a time.
+  ;;
+  ;; Note: In both cases, the build farm at *CUIRASS-URL* is trusted to
+  ;; provide a valid database.  If the build farm is compromised, it could
+  ;; give something that does not correspond to 'guix build -m
+  ;; etc/disarchive-manifest.scm'.  Such malicious changes to the database
+  ;; would be detected since the database is content-addressed; the only risk
+  ;; is denial of service, if the database lacks entries or if it contains
+  ;; bogus entries.
+  (match (build-products build)
+    ((product)
+     (build-product-path product))
+    (_
+     (build-derivation build))))
+
+(define* (copy-atomically source target #:key (gzip? #t))
+  "Copy SOURCE to TARGET in an atomic fashion, replacing TARGET if it exists.
+When GZIP? is true, compress SOURCE and write the output to TARGET.gz; this
+scheme allows nginx with the 'gzip_static_module' to serve files as-is."
+  (let* ((target (if gzip? (string-append target ".gz") target))
+         (pivot  (string-append target ".part")))
+    (if gzip?
+        (call-with-output-file pivot
+          (lambda (port)
+            (call-with-gzip-output-port port
+              (lambda (port)
+                (call-with-input-file source
+                  (lambda (input)
+                    (dump-port input port))))
+              #:buffer-size 32768)))
+        (copy-file source pivot))
+    (rename-file pivot target)))
+
+(define* (sync-directories source target #:key (gzip? #t))
+  "Copy files from SOURCE, a directory name, to TARGET, atomically."
+  (for-each (lambda (file)
+              (let* ((base   (string-drop file (string-length source)))
+                     (target (string-append target base)))
+                (mkdir-p (dirname target))
+
+                ;; Copy FILE atomically so that, if TARGET is being served
+                ;; over HTTP, users will fetch a complete file.
+                (copy-atomically file target)))
+            (find-files source)))
+
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (main . args)
+  (match args
+    ((_ target)
+     (with-store store
+       (info (G_ "connecting to Cuirass instance at ~a...~%")
+             (*cuirass-url*))
+       (let ((collection (latest-disarchive-collection)))
+         (info (G_ "building '~a'...~%") collection)
+         (build-things store (list collection))
+
+         (let ((item (if (string-suffix? ".drv" collection)
+                         (derivation->output-path
+                          (read-derivation-from-file collection))
+                         collection)))
+           (info (G_ "copying '~a' to '~a'...~%") item target)
+           (sync-directories item target #:gzip? #t)))))
+    ((command target url)
+     (parameterize ((*cuirass-url* url))
+       (main command target)))
+    ((command . _)
+     (leave (G_ "Usage: ~a TARGET [CUIRASS-URL]
+
+Build or substitute the latest version of the Disarchive database and copy it
+to TARGET, a directory.  When CUIRASS-URL is specified, connect to that
+specific Cuirass instance.\n")
+            (basename command)))))
+
+(apply main (command-line))