data-service/guix-data-service/jobs/load-new-guix-revision.scm

;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero 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
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (guix-data-service jobs load-new-guix-revision)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 hash-table)
  #:use-module (rnrs exceptions)
  #:use-module (json)
  #:use-module (squee)
  #:use-module (guix monads)
  #:use-module (guix store)
  #:use-module (guix channels)
  #:use-module (guix inferior)
  #:use-module (guix profiles)
  #:use-module (guix utils)
  #:use-module (guix i18n)
  #:use-module (guix progress)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix build utils)
  #:use-module ((guix build syscalls)
                #:select (set-thread-name))
  #:use-module (guix-data-service config)
  #:use-module (guix-data-service database)
  #:use-module (guix-data-service utils)
  #:use-module (guix-data-service model utils)
  #:use-module (guix-data-service model build)
  #:use-module (guix-data-service model channel-instance)
  #:use-module (guix-data-service model channel-news)
  #:use-module (guix-data-service model package)
  #:use-module (guix-data-service model package-derivation-by-guix-revision-range)
  #:use-module (guix-data-service model git-repository)
  #:use-module (guix-data-service model guix-revision)
  #:use-module (guix-data-service model package-derivation)
  #:use-module (guix-data-service model guix-revision-package-derivation)
  #:use-module (guix-data-service model license)
  #:use-module (guix-data-service model license-set)
  #:use-module (guix-data-service model lint-checker)
  #:use-module (guix-data-service model lint-warning)
  #:use-module (guix-data-service model lint-warning-message)
  #:use-module (guix-data-service model location)
  #:use-module (guix-data-service model package-metadata)
  #:use-module (guix-data-service model derivation)
  #:use-module (guix-data-service model system-test)
  #:export (log-for-job
            count-log-parts
            combine-log-parts!
            fetch-unlocked-jobs
            process-load-new-guix-revision-job
            select-load-new-guix-revision-job-metrics
            select-job-for-commit
            select-jobs-and-events
            select-recent-job-events
            select-unprocessed-jobs-and-events
            select-jobs-and-events-for-commit
            guix-revision-loaded-successfully?
            record-job-event
            enqueue-load-new-guix-revision-job
            most-recent-n-load-new-guix-revision-jobs))

(define (log-part-sequence-name job-id)
  (simple-format #f "load_new_guix_revision_job_log_parts_id_seq_~A" job-id))

(define* (log-port job-id conn
                   #:key
                   delete-existing-log-parts?
                   real-output-port)
  (define output-port
    (or real-output-port
        (current-output-port)))

  (define buffer "")

  (define (insert job_id s)
    (exec-query
     conn
     (string-append
      "
INSERT INTO load_new_guix_revision_job_log_parts (id, job_id, contents)
VALUES (nextval('" (log-part-sequence-name job_id) "'), $1, $2)")
     (list job_id s)))

  (define (log-string s)
    (if (string-contains s "\n")
        (let ((output (string-append buffer s)))
          (set! buffer "") ; clear the buffer
          (catch #t
            (lambda ()
              (insert job-id output)
              (display output output-port))
            (lambda (key . args)
              (display
               (simple-format
                #f
                "
error: ~A: ~A
error: could not insert log part: '~A'\n\n"
                key args output)
               output-port)
              (catch #t
                (lambda ()
                  (insert
                   job-id
                   (simple-format
                    #f
                    "
guix-data-service: error: missing log line: ~A
\n" key)))
                (lambda ()
                  #t)))))
        (set! buffer (string-append buffer s))))

  (exec-query
   conn
   (simple-format #f "CREATE SEQUENCE IF NOT EXISTS ~A"
                  (log-part-sequence-name job-id)))
  (when delete-existing-log-parts?
    ;; TODO, this is useful when re-running jobs, but I'm not sure that should
    ;; be a thing, jobs should probably be only attempted once.
    (exec-query
     conn
     "DELETE FROM load_new_guix_revision_job_log_parts WHERE job_id = $1"
     (list job-id)))

  (let ((port
         (make-soft-port
          (vector (lambda (c)
                    (set! buffer (string-append buffer (string c))))
                  log-string
                  (lambda ()
                    (force-output output-port))
                  #f ; fetch one character
                  (lambda ()
                    ;; close port
                    #f)
                  #f) ; number of characters that can be read
          "w")))
    (setvbuf port 'line)
    port))

(define (setup-port-for-inferior-error-output job-id real-output-port)
  (define (insert conn job_id s)
    (exec-query
     conn
     (string-append "
INSERT INTO load_new_guix_revision_job_log_parts (id, job_id, contents)
VALUES (nextval('" (log-part-sequence-name job_id) "'), $1, $2)")
     (list job_id s)))

  (match (pipe)
    ((port-to-read-from . port-to-write-to)

     (setvbuf port-to-read-from 'line)
     (setvbuf port-to-write-to 'line)
     (call-with-new-thread
      (lambda ()
        (catch 'system-error
          (lambda ()
            (set-thread-name "inferior logging"))
          (const #t))

        (with-postgresql-connection
         (simple-format #f "~A inferior error logging" job-id)
         (lambda (logging-conn)
           (let loop ((line (get-line port-to-read-from)))
             (let ((line-with-newline
                    (string-append line "\n")))
               (catch #t
                 (lambda ()
                   (insert logging-conn job-id line-with-newline)
                   (display line-with-newline real-output-port))
                 (lambda (key . args)
                   (display
                    (simple-format
                     #f
                     "
error: ~A: ~A
error: could not insert log part: '~A'\n\n"
                     key args line)
                    real-output-port)
                   (catch #t
                     (lambda ()
                       (insert
                        logging-conn
                        job-id
                        (simple-format
                         #f
                         "
guix-data-service: error: missing log line: ~A
\n" key)))
                     (lambda ()
                       #t)))))
             (loop (get-line port-to-read-from)))))))

     port-to-write-to)))

(define real-error-port
  (make-parameter (current-error-port)))

(define inferior-error-port
  (make-parameter (current-error-port)))

(define* (log-for-job conn job-id
                      #:key
                      character-limit
                      start-character)
  (define (sql-html-escape s)
    (string-append
     "replace("
     (string-append
      "replace("
      (string-append
       "replace("
       s
       ",'&','&amp;')")
      ",'<','&lt;')")
     ",'>','&gt;')"))

  (define (get-characters s)
    (if start-character
        (simple-format #f "substr(~A, ~A, ~A)"
                       s start-character
                       character-limit)
        (simple-format #f "right(~A, ~A)" s character-limit)))

  (define log-query
    (string-append
     "SELECT "
     (sql-html-escape (get-characters "contents"))
     " FROM load_new_guix_revision_job_logs"
     " WHERE job_id = $1 AND contents IS NOT NULL"))

  (define parts-query
    (string-append
     "SELECT "
     (sql-html-escape
      (get-characters "STRING_AGG(contents, '' ORDER BY id ASC)"))
     " FROM load_new_guix_revision_job_log_parts WHERE job_id = $1"))

  (match (exec-query conn log-query (list job-id))
    (((contents))
     contents)
    (()
     (match (exec-query conn parts-query (list job-id))
       (((contents))
        contents)))))

(define (insert-empty-log-entry conn job-id)
  (exec-query
   conn
   "DELETE FROM load_new_guix_revision_job_logs WHERE job_id = $1"
   (list job-id))
  (exec-query
   conn
   "INSERT INTO load_new_guix_revision_job_logs (job_id, contents) VALUES
($1, NULL)"
   (list job-id)))

(define (count-log-parts conn job-id)
  (match (exec-query
          conn
          "
SELECT COUNT(*)
FROM load_new_guix_revision_job_log_parts
WHERE job_id = $1"
          (list job-id))
    (((id))
     (string->number id))))

(define (combine-log-parts! conn job-id)
  (with-postgresql-transaction
   conn
   (lambda (conn)
     (exec-query
      conn
      (string-append
       "
UPDATE load_new_guix_revision_job_logs SET contents = (
  SELECT STRING_AGG(contents, '' ORDER BY id ASC)
  FROM load_new_guix_revision_job_log_parts
  WHERE job_id = $1
  GROUP BY job_id
)
WHERE job_id = $1")
      (list job-id))
     (exec-query
      conn
      "DELETE FROM load_new_guix_revision_job_log_parts WHERE job_id = $1"
      (list job-id)))))

(define (drop-log-parts-sequence conn job-id)
  (with-postgresql-transaction
   conn
   (lambda (conn)
     (exec-query conn
                 "SET LOCAL lock_timeout = '10s'")
     (with-exception-handler
         (lambda (exn)
           (simple-format (current-error-port)
                          "error when dropping sequence: ~A"
                          exn))
       (lambda ()
         (exec-query conn
                     (string-append
                      "DROP SEQUENCE IF EXISTS "
                      (log-part-sequence-name job-id))))
       #:unwind? #t))))

(define (vacuum-log-parts-table conn)
  (exec-query
   conn
   "VACUUM load_new_guix_revision_job_log_parts"))

(define inferior-package-id
  (@@ (guix inferior) inferior-package-id))

(define (record-start-time action)
  (simple-format #t "debug: Starting ~A\n" action)
  (cons action
        (current-time)))

(define record-end-time
  (match-lambda
    ((action . start-time)
     (let ((time-taken (- (current-time) start-time)))
       (simple-format #t "debug: Finished ~A, took ~A seconds\n"
                      action time-taken)))))

(define (inferior-guix-systems inf)
  ;; The order shouldn't matter here, but bugs in Guix can lead to different
  ;; results depending on the order, so sort the systems to try and provide
  ;; deterministic behaviour
  (sort
   (cond
    ((inferior-eval
      '(defined? 'systems
         (resolve-module '(guix platform)))
      inf)

     (remove
      (lambda (system)
        ;; There aren't currently bootstrap binaries for s390x-linux, so this
        ;; just leads to lots of errors
        (string=? system "s390x-linux"))
      (inferior-eval
       '((@ (guix platform) systems))
       inf)))

    (else
     (inferior-eval
      '(@ (guix packages) %supported-systems)
      inf)))
   string<?))

(define (all-inferior-system-tests inf store guix-source guix-commit)
  (define inf-systems
    (inferior-guix-systems inf))

  (define extract
    `(lambda (store)
       (parameterize ((current-guix-package
                       (channel-source->package ,guix-source
                                                #:commit ,guix-commit)))
         (map
          (lambda (system-test)
            (let ((stats (gc-stats)))
              (simple-format
               (current-error-port)
               "inferior heap: ~a MiB used (~a MiB heap)~%"
               (round
                (/ (- (assoc-ref stats 'heap-size)
                      (assoc-ref stats 'heap-free-size))
                   (expt 2. 20)))
               (round
                (/ (assoc-ref (gc-stats) 'heap-size)
                   (expt 2. 20)))))

            (list (system-test-name system-test)
                  (system-test-description system-test)
                  (filter-map
                   (lambda (system)
                     (simple-format
                      (current-error-port)
                      "guix-data-service: computing derivation for ~A system test (on ~A)\n"
                      (system-test-name system-test)
                      system)
                     (catch
                       #t
                       (lambda ()
                         (cons
                          system
                          (parameterize ((%current-system system))
                            (derivation-file-name
                             (run-with-store store
                               (mbegin %store-monad
                                 (system-test-value system-test)))))))
                       (lambda (key . args)
                         (simple-format
                          (current-error-port)
                          "guix-data-service: error computing derivation for system test ~A (~A): ~A: ~A\n"
                          (system-test-name system-test)
                          system
                          key args)
                         #f)))
                   (list ,@inf-systems))
                  (match (system-test-location system-test)
                    (($ <location> file line column)
                     (list file
                           line
                           column)))))
          (all-system-tests)))))

  (catch
    #t
    (lambda ()
      (inferior-eval
       ;; For channel-source->package
       '(use-modules (gnu packages package-management))
       inf)

      (let ((system-test-data
             (with-time-logging "getting system tests"
               (inferior-eval-with-store inf store extract))))

        (for-each (lambda (derivation-file-names-by-system)
                    (for-each (lambda (derivation-file-name)
                                (add-temp-root store derivation-file-name))
                              (map cdr derivation-file-names-by-system)))
                  (map third system-test-data))

        system-test-data))
    (lambda (key . args)
      (display (backtrace) (current-error-port))
      (display "\n" (current-error-port))
      (simple-format
       (current-error-port)
       "error: all-inferior-system-tests: ~A: ~A\n"
       key args)

      #f)))

(define (all-inferior-lint-warnings inf store packages)
  (define locales
    '("cs_CZ.UTF-8"
      "da_DK.UTF-8"
      "de_DE.UTF-8"
      "eo_EO.UTF-8"
      "es_ES.UTF-8"
      "fr_FR.UTF-8"
      "hu_HU.UTF-8"
      "nl_NL.UTF-8"
      "pl_PL.UTF-8"
      "pt_BR.UTF-8"
      ;;"sr_SR.UTF-8"
      "sv_SE.UTF-8"
      "vi_VN.UTF-8"
      "zh_CN.UTF-8"))

  (define (cleanup-inferior inf)
    (format (current-error-port)
            "inferior heap before cleanup: ~a MiB used (~a MiB heap)~%"
            (round
             (/ (inferior-eval
                 '(let ((stats (gc-stats)))
                    (- (assoc-ref stats 'heap-size)
                       (assoc-ref stats 'heap-free-size)))
                 inf)
                (expt 2. 20)))
            (round
             (/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
                (expt 2. 20))))

    ;; Clean the cached store connections, as there are caches associated with
    ;; these that take up lots of memory
    (inferior-eval
     '(when (defined? '%store-table) (hash-clear! %store-table))
     inf)

    (catch
      'match-error
      (lambda ()
        (inferior-eval '(invalidate-derivation-caches!) inf))
      (lambda (key . args)
        (simple-format
         (current-error-port)
         "warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n")))

    (inferior-eval '(gc) inf)

    (format (current-error-port)
            "inferior heap after cleanup: ~a MiB used (~a MiB heap)~%"
            (round
             (/ (inferior-eval
                 '(let ((stats (gc-stats)))
                    (- (assoc-ref stats 'heap-size)
                       (assoc-ref stats 'heap-free-size)))
                 inf)
                (expt 2. 20)))
            (round
             (/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
                (expt 2. 20)))))

  (define (lint-warnings-for-checker packages checker-name)
    `(lambda (store)
       (let* ((checker (find (lambda (checker)
                               (eq? (lint-checker-name checker)
                                    ',checker-name))
                             %local-checkers))
              (check (lint-checker-check checker)))

         (define lint-checker-requires-store?-defined?
           (defined? 'lint-checker-requires-store?
             (resolve-module '(guix lint))))

         (define (process-lint-warning lint-warning)
           (list
            (match (lint-warning-location lint-warning)
              (($ <location> file line column)
               (list (if (string-prefix? "/gnu/store/" file)
                         ;; Convert a string like
                         ;; /gnu/store/53xh0mpigin2rffg31s52x5dc08y0qmr-guix-module-union/share/guile/site/2.2/gnu/packages/xdisorg.scm
                         ;;
                         ;; This happens when the checker uses
                         ;; package-field-location.
                         (string-join (drop (string-split file #\/) 8) "/")
                         file)
                     line
                     column)))
            (let* ((source-locale "en_US.UTF-8")
                   (source-message
                    (begin
                      (setlocale LC_MESSAGES source-locale)
                      (lint-warning-message lint-warning)))
                   (messages-by-locale
                    (filter-map
                     (lambda (locale)
                       (catch 'system-error
                         (lambda ()
                           (setlocale LC_MESSAGES locale))
                         (lambda (key . args)
                           (error
                            (simple-format
                             #f
                             "error changing locale to ~A: ~A ~A"
                             locale key args))))
                       (let ((message
                              (lint-warning-message lint-warning)))
                         (setlocale LC_MESSAGES source-locale)
                         (if (string=? message source-message)
                             #f
                             (cons locale message))))
                     (list ,@locales))))
              (cons (cons source-locale source-message)
                    messages-by-locale))))

         (filter-map
          (lambda (package-id)
            (let* ((package (hashv-ref %package-table package-id))
                   (warnings
                    (map process-lint-warning
                         (with-exception-handler
                             (lambda (exn)
                               (simple-format (current-error-port)
                                              "exception checking ~A with ~A checker: ~A\n"
                                              package ',checker-name exn)
                               (raise-exception exn))
                           (lambda ()
                             (if (and lint-checker-requires-store?-defined?
                                      (lint-checker-requires-store? checker))

                                 (check package #:store store)
                                 (check package)))
                           #:unwind? #t))))
              (if (null? warnings)
                  #f
                  (cons package-id warnings))))
          (list ,@(map inferior-package-id packages))))))

  (and
   (or (inferior-eval '(and (resolve-module '(guix lint) #:ensure #f)
                            (use-modules (guix lint))
                            #t)
                      inf)
       (begin
         (simple-format (current-error-port)
                        "warning: no (guix lint) module found\n")
         #f))
   (let ((checkers
          (inferior-eval
           `(begin
              (define (lint-descriptions-by-locale checker)
                (let* ((source-locale "en_US.UTF-8")
                       (source-description
                        (begin
                          (setlocale LC_MESSAGES source-locale)
                          (G_ (lint-checker-description checker))))
                       (descriptions-by-locale
                        (filter-map
                         (lambda (locale)
                           (catch 'system-error
                             (lambda ()
                               (setlocale LC_MESSAGES locale))
                             (lambda (key . args)
                               (error
                                (simple-format
                                 #f
                                 "error changing locale to ~A: ~A ~A"
                                 locale key args))))
                           (let ((description
                                  (G_ (lint-checker-description checker))))
                             (setlocale LC_MESSAGES source-locale)
                             (if (string=? description source-description)
                                 #f
                                 (cons locale description))))
                         (list ,@locales))))
                  (cons (cons source-locale source-description)
                        descriptions-by-locale)))

              (map (lambda (checker)
                     (list (lint-checker-name checker)
                           (lint-descriptions-by-locale checker)
                           (if (memq checker %network-dependent-checkers)
                               #t
                               #f)))
                   %all-checkers))
           inf)))
     (map
      (match-lambda
        ((name description network-dependent?)
         (cons
          (list name description network-dependent?)
          (if (or network-dependent?
                  (eq? name 'derivation))
              '()
              (let ((warnings
                     (with-time-logging (simple-format #f "getting ~A lint warnings"
                                                       name)
                       (inferior-eval-with-store
                        inf
                        store
                        (lint-warnings-for-checker packages
                                                   name)))))
                (cleanup-inferior inf)
                warnings)))))
      checkers))))

(define (all-inferior-package-derivations store inf packages)
  (define inf-systems
    (inferior-guix-systems inf))

  (define inf-targets
    (cond
     ((inferior-eval
       '(defined? 'targets
          (resolve-module '(guix platform)))
       inf)
      (sort
       (inferior-eval
        '((@ (guix platform) targets))
        inf)
       string<?))

     (else
      '("arm-linux-gnueabihf"
        "aarch64-linux-gnu"
        "mips64el-linux-gnu"
        "powerpc-linux-gnu"
        "powerpc64le-linux-gnu"
        "riscv64-linux-gnu"
        "i586-pc-gnu"
        "i686-w64-mingw32"
        "x86_64-w64-mingw32"))))

  (define cross-derivations
    `(("x86_64-linux" . ,(remove
                          (lambda (target)
                            ;; Remove targets that don't make much sense
                            (member target
                                    '("x86_64-linux-gnu"
                                      "i686-linux-gnu")))
                          inf-targets))))

  (define supported-system-pairs
    (map (lambda (system)
           (cons system #f))
         inf-systems))

  (define supported-system-cross-build-pairs
    (append-map
     (match-lambda
       ((system . targets)
        (map (lambda (target)
               (cons system target))
             targets)))
     cross-derivations))

  (define proc
    '(lambda (store system-target-pair)
       (define target-system-alist
         (if (defined? 'platforms (resolve-module '(guix platform)))
             (filter-map
              (lambda (platform)
                (and
                 (platform-target platform)
                 (cons (platform-target platform)
                       (platform-system platform))))
              (platforms))

             '(("arm-linux-gnueabihf"   . "armhf-linux")
               ("aarch64-linux-gnu"     . "aarch64-linux")
               ("mips64el-linux-gnu"    . "mips64el-linux")
               ("powerpc-linux-gnu"     . "powerpc-linux")
               ("powerpc64le-linux-gnu" . "powerpc64le-linux")
               ("riscv64-linux-gnu"     . "riscv64-linux")
               ("i586-pc-gnu"           . "i586-gnu"))))

       (define package-transitive-supported-systems-supports-multiple-arguments? #t)
       (define (get-supported-systems package system)
         (or (and package-transitive-supported-systems-supports-multiple-arguments?
                  (catch
                    'wrong-number-of-args
                    (lambda ()
                      (package-transitive-supported-systems package system))
                    (lambda (key . args)
                      ;; Older Guix revisions don't support two
                      ;; arguments to
                      ;; package-transitive-supported-systems
                      (simple-format
                       (current-error-port)
                       "info: package-transitive-supported-systems doesn't support two arguments, falling back to package-supported-systems\n")
                      (set! package-transitive-supported-systems-supports-multiple-arguments? #f)
                      #f)))
             (catch
               #t
               (lambda ()
                 (package-supported-systems package))
               (lambda (key . args)
                 (simple-format
                  (current-error-port)
                  "error: while processing ~A, unable to compute supported systems\n"
                  (package-name package))
                 (simple-format
                  (current-error-port)
                  "error ~A: ~A\n" key args)
                 #f))))

       (define (derivation-for-system-and-target inferior-package-id package system target)
         (catch
           'misc-error
           (lambda ()
             (guard (c ((package-cross-build-system-error? c)
                        #f))
               (let ((derivation
                      (if target
                          (package-cross-derivation store package
                                                    target
                                                    system)
                          (package-derivation store package system))))
                 ;; You don't always get what you ask for, so check
                 (if (string=? system (derivation-system derivation))
                     (list inferior-package-id
                           system
                           target
                           (let ((file-name
                                  (derivation-file-name derivation)))
                             (add-temp-root store file-name)
                             file-name))
                     (begin
                       (simple-format
                        (current-error-port)
                        "warning: request for ~A derivation for ~A produced a derivation for system ~A\n"
                        system
                        (package-name package)
                        (derivation-system derivation))
                       #f)))))
           (lambda args
             (simple-format
              (current-error-port)
              "warning: error when computing ~A derivation for system ~A (~A): ~A\n"
              (package-name package)
              system
              (or target "no target")
              args)
             #f)))

       (filter-map
        (lambda (inferior-package-id)
          (let ((package (hashv-ref %package-table inferior-package-id)))
            (catch
              #t
              (lambda ()
                (let* ((system (car system-target-pair))
                       (target (cdr system-target-pair))
                       (supported-systems (get-supported-systems package system))
                       (system-supported?
                        (and supported-systems
                             (->bool (member system supported-systems))))
                       (target-supported?
                        (or (not target)
                            (let ((system-for-target
                                   (assoc-ref target-system-alist
                                              target)))
                              (or (not system-for-target)
                                  (->bool
                                   (member system-for-target
                                           (package-supported-systems package)
                                           string=?)))))))

                  (when (string=? (package-name package) "guix")
                    (simple-format
                     (current-error-port)
                     "looking at guix package (supported systems: ~A, system supported: ~A, target supported: ~A\n"
                     supported-systems
                     system-supported?
                     target-supported?))

                  (if system-supported?
                      (if target-supported?
                          (derivation-for-system-and-target inferior-package-id
                                                            package
                                                            system
                                                            target)
                          #f)
                      #f)))
              (lambda (key . args)
                (if (and (eq? key 'system-error)
                         (eq? (car args) 'fport_write))
                    (begin
                      (simple-format
                       (current-error-port)
                       "error: while processing ~A, exiting: ~A: ~A\n"
                       (package-name package)
                       key
                       args)
                      (exit 1))
                    (begin
                      (simple-format
                       (current-error-port)
                       "error: while processing ~A ignoring error: ~A: ~A\n"
                       (package-name package)
                       key
                       args)
                      #f))))))
        gds-inferior-package-ids)))

  (inferior-eval
   '(when (defined? 'systems (resolve-module '(guix platform)))
      (use-modules (guix platform)))
   inf)

  (inferior-eval
   `(define gds-inferior-package-ids
      (list ,@(map inferior-package-id packages)))
   inf)

  (inferior-eval
   `(define gds-packages-proc ,proc)
   inf)

  (append-map!
   (lambda (system-target-pair)
     (format (current-error-port)
             "heap size: ~a MiB~%"
             (round
              (/ (assoc-ref (gc-stats) 'heap-size)
                 (expt 2. 20))))

     (format (current-error-port)
             "inferior heap before cleanup: ~a MiB used (~a MiB heap)~%"
             (round
              (/ (inferior-eval
                  '(let ((stats (gc-stats)))
                     (- (assoc-ref stats 'heap-size)
                        (assoc-ref stats 'heap-free-size)))
                  inf)
                 (expt 2. 20)))
             (round
              (/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
                 (expt 2. 20))))
     (catch
       'match-error
       (lambda ()
         (inferior-eval '(invalidate-derivation-caches!) inf))
       (lambda (key . args)
         (simple-format
          (current-error-port)
          "warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n")))

     ;; Clean the cached store connections, as there are caches associated
     ;; with these that take up lots of memory
     (inferior-eval '(when (defined? '%store-table) (hash-clear! %store-table)) inf)

     (inferior-eval '(gc) inf)

     (format (current-error-port)
             "inferior heap after cleanup: ~a MiB used (~a MiB heap)~%"
             (round
              (/ (inferior-eval
                  '(let ((stats (gc-stats)))
                     (- (assoc-ref stats 'heap-size)
                        (assoc-ref stats 'heap-free-size)))
                  inf)
                 (expt 2. 20)))
             (round
              (/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
                 (expt 2. 20))))

     (with-time-logging
         (simple-format #f "getting derivations for ~A" system-target-pair)
       (inferior-eval-with-store
        inf
        store
        `(lambda (store)
           (gds-packages-proc store (cons ,(car system-target-pair)
                                          ,(cdr system-target-pair)))))))
   (append supported-system-pairs
           supported-system-cross-build-pairs)))

(define (deduplicate-inferior-packages packages)
  (pair-fold
   (lambda (pair result)
     (if (null? (cdr pair))
         (cons (first pair) result)
         (let* ((a (first pair))
                (b (second pair))
                (a-name (inferior-package-name a))
                (b-name (inferior-package-name b))
                (a-version (inferior-package-version a))
                (b-version (inferior-package-version b)))
           (if (and (string=? a-name b-name)
                    (string=? a-version b-version))
               (begin
                 (simple-format (current-error-port)
                                "warning: ignoring duplicate package: ~A (~A)\n"
                                a-name
                                a-version)
                 result)
               (cons a result)))))
   '()
   (sort packages
         (lambda (a b)
           (let ((a-name (inferior-package-name a))
                 (b-name (inferior-package-name b)))
             (if (string=? a-name b-name)
                 (let ((a-version (inferior-package-version a))
                       (b-version (inferior-package-version b)))
                   (if (string=? a-version b-version)
                       ;; The name and version are the same, so try and pick
                       ;; the same package each time, by looking at the
                       ;; location.
                       (let ((a-location (inferior-package-location a))
                             (b-location (inferior-package-location b)))
                         (> (location-line a-location)
                            (location-line b-location)))
                       (string<? a-version
                                 b-version)))
                 (string<? a-name
                           b-name)))))))

(define (inferior-packages-plus-replacements inf)
  (let* ((packages (inferior-packages inf))
         (replacements (filter-map inferior-package-replacement packages))
         (non-exported-replacements
          (let ((package-id-hash-table (make-hash-table)))
            (for-each (lambda (pkg)
                        (hash-set! package-id-hash-table
                                   (inferior-package-id pkg)
                                   #t))
                      packages)

            (filter (lambda (pkg)
                      (eq? #f
                           (hash-ref package-id-hash-table
                                     (inferior-package-id pkg))))
                    replacements)))

         (deduplicated-packages
          ;; This isn't perfect, sometimes there can be two packages with the
          ;; same name and version, but different derivations.  Guix will warn
          ;; about this case though, generally this means only one of the
          ;; packages should be exported.
          (deduplicate-inferior-packages
           (append! packages non-exported-replacements))))


    deduplicated-packages))

(define* (all-inferior-packages-data inf packages #:key (process-replacements? #t))
  (let* ((package-license-data
          (with-time-logging "fetching inferior package license metadata"
            (inferior-packages->license-data inf packages)))
         (package-metadata
          (with-time-logging "fetching inferior package metadata"
            (map
             (lambda (package)
               (let ((translated-package-descriptions-and-synopsis
                      (inferior-packages->translated-package-descriptions-and-synopsis
                       inf package)))
                 (list (non-empty-string-or-false
                        (inferior-package-home-page package))
                       (inferior-package-location package)
                       (car translated-package-descriptions-and-synopsis)
                       (cdr translated-package-descriptions-and-synopsis))))
             packages)))
         (package-replacement-data
          (if process-replacements?
              (map (lambda (package)
                     (let ((replacement (inferior-package-replacement package)))
                       (if replacement
                           ;; I'm not sure if replacements can themselves be
                           ;; replaced, but I do know for sure that there are
                           ;; infinite chains of replacements (python(2)-urllib3
                           ;; in 7c4c781aa40c42d4cd10b8d9482199f3db345e1b for
                           ;; example).
                           ;;
                           ;; This code currently just capures the first level
                           ;; of replacements
                           (first
                            (all-inferior-packages-data
                             inf
                             (list replacement)
                             #:process-replacements? #f))
                           #f)))
                   packages)
              #f)))

    `((names        . ,(map inferior-package-name packages))
      (versions     . ,(map inferior-package-version packages))
      (license-data . ,package-license-data)
      (metadata     . ,package-metadata)
      (replacemnets . ,package-replacement-data))))

(define (insert-packages conn inferior-packages-data)
  (let*-values
      (((package-license-set-ids)
        (inferior-packages->license-set-ids
         conn
         (inferior-packages->license-id-lists
          conn
          (assq-ref inferior-packages-data 'license-data))))
       ((all-package-metadata-ids new-package-metadata-ids)
        (with-time-logging "inserting package metadata entries"
          (inferior-packages->package-metadata-ids
           conn
           (assq-ref inferior-packages-data 'metadata)
           package-license-set-ids)))
       ((replacement-ids)
        (or (and=> (assq-ref inferior-packages-data 'replacements)
                   (lambda (all-replacement-data)
                     (with-time-logging "inserting package replacements"
                       (map (lambda (replacement-data)
                              (if replacement-data
                                  (first
                                   (insert-packages conn (list replacement-data)))
                                  (cons "integer" NULL)))
                            all-replacement-data))))
            (make-list (length package-license-set-ids)
                       (cons "integer" NULL)))))

    (unless (null? new-package-metadata-ids)
      (with-time-logging "fetching package metadata tsvector entries"
        (insert-package-metadata-tsvector-entries
         conn new-package-metadata-ids)))

    (with-time-logging "getting package-ids"
      (inferior-packages->package-ids
       conn
       (zip (assq-ref inferior-packages-data 'names)
            (assq-ref inferior-packages-data 'versions)
            all-package-metadata-ids
            replacement-ids)))))

(define (insert-lint-warnings conn inferior-package-id->package-database-id
                              lint-checker-ids
                              lint-warnings-data)
  (lint-warnings-data->lint-warning-ids
   conn
   (append-map
    (lambda (lint-checker-id warnings-by-package-id)
      (append-map
       (match-lambda
         ((package-id . warnings)
          (map
           (match-lambda
             ((location-data messages-by-locale)
              (let ((location-id
                     (location->location-id
                      conn
                      (apply location location-data)))
                    (lint-warning-message-set-id
                     (lint-warning-message-data->lint-warning-message-set-id
                      conn
                      messages-by-locale)))
                (list lint-checker-id
                      (inferior-package-id->package-database-id package-id)
                      location-id
                      lint-warning-message-set-id))))
           (fold (lambda (location-and-messages result)
                   (if (member location-and-messages result)
                       (begin
                         (apply
                          simple-format
                          (current-error-port)
                          "warning: skipping duplicate lint warning ~A ~A\n"
                          location-and-messages)
                         result)
                       (append result
                               (list location-and-messages))))
                 '()
                 warnings))))
       warnings-by-package-id))
    lint-checker-ids
    (map cdr lint-warnings-data))))

(define (inferior-data->package-derivation-ids
         conn inf
         inferior-package-id->package-database-id
         inferior-data-4-tuples)
  (let ((derivation-ids
         (derivation-file-names->derivation-ids
          conn
          (map fourth inferior-data-4-tuples)))
        (flat-package-ids-systems-and-targets
         (map
          (match-lambda
            ((inferior-package-id system target derivation-file-name)
             (list (inferior-package-id->package-database-id
                    inferior-package-id)
                   system
                   (or target ""))))
          inferior-data-4-tuples)))


    (insert-package-derivations conn
                                flat-package-ids-systems-and-targets
                                derivation-ids)))

(define guix-store-path
  (let ((store-path #f))
    (lambda (store)
      (if (and store-path
               (file-exists? store-path))
          store-path
          (let ((config-guix (%config 'guix)))
            (if (and (file-exists? config-guix)
                     (string-prefix? "/gnu/store/" config-guix))
                (begin
                  (set! store-path
                    (dirname
                     (dirname
                      (%config 'guix))))
                  store-path)
                (begin
                  (invalidate-derivation-caches!)
                  (hash-clear! (@@ (guix packages) %derivation-cache))
                  (let* ((guix-package (@ (gnu packages package-management)
                                          guix))
                         (derivation (package-derivation store guix-package)))
                    (with-time-logging "building the guix derivation"
                      (build-derivations store (list derivation)))

                    (let ((new-store-path
                           (derivation->output-path derivation)))
                      (set! store-path new-store-path)
                      (simple-format (current-error-port)
                                     "debug: guix-store-path: ~A\n"
                                     new-store-path)
                      new-store-path)))))))))

(define (nss-certs-store-path store)
  (let* ((nss-certs-package (@ (gnu packages certs)
                               nss-certs))
         (derivation (package-derivation store nss-certs-package)))
    (with-time-logging "building the nss-certs derivation"
      (build-derivations store (list derivation)))
    (derivation->output-path derivation)))

(define (channel->source-and-derivation-file-names-by-system conn store channel
                                                  fetch-with-authentication?)
  (define use-container? (defined?
                           'open-inferior/container
                           (resolve-module '(guix inferior))))

  (define (inferior-code channel-instance systems)
    `(lambda (store)
       (let* ((instances
               (list
                (channel-instance
                 (channel (name ',(channel-name channel))
                          (url    ,(channel-url channel))
                          (branch ,(channel-branch channel))
                          (commit ,(channel-commit channel)))
                 ,(channel-instance-commit channel-instance)
                 ,(channel-instance-checkout channel-instance)))))
         (map
          (lambda (system)
            (simple-format
             (current-error-port)
             "guix-data-service: computing the derivation-file-name for ~A\n"
             system)

            (let ((manifest
                   (catch #t
                     (lambda ()
                       ((channel-instances->manifest instances #:system system) store))
                     (lambda (key . args)
                       (simple-format
                        (current-error-port)
                        "error: while computing manifest entry derivation for ~A\n"
                        system)
                       (simple-format
                        (current-error-port)
                        "error ~A: ~A\n" key args)
                       #f))))
              (define (add-tmp-root-and-return-drv drv)
                (add-temp-root store drv)
                drv)

              `(,system
                .
                ((manifest-entry-item
                  . ,(and manifest
                          (add-tmp-root-and-return-drv
                           (derivation-file-name
                            (manifest-entry-item
                             (first
                              (manifest-entries manifest)))))))
                 (profile
                  . ,(catch #t
                       (lambda ()
                         (and manifest
                              (add-tmp-root-and-return-drv
                               (derivation-file-name
                                (parameterize ((%current-system system))
                                  (run-with-store store
                                    (profile-derivation
                                     manifest
                                     #:hooks %channel-profile-hooks)))))))
                       (lambda (key . args)
                         (simple-format
                          (current-error-port)
                          "error: while computing profile derivation for ~A\n"
                          system)
                         (simple-format
                          (current-error-port)
                          "error ~A: ~A\n" key args)
                         #f)))))))
          (list ,@systems)))))

    (let ((inferior
           (if use-container?
               (open-inferior/container
                store
                (guix-store-path store)
                #:extra-shared-directories
                '("/gnu/store")
                #:extra-environment-variables
                (list (string-append
                       "SSL_CERT_DIR=" (nss-certs-store-path store))))
               (begin
                 (simple-format #t "debug: using open-inferior\n")
                 (open-inferior (guix-store-path store)
                                #:error-port (inferior-error-port))))))

      (define (start-inferior-and-return-derivation-file-names)
        ;; /etc is only missing if open-inferior/container has been used
        (when use-container?
          (inferior-eval
           '(begin
              ;; Create /etc/pass, as %known-shorthand-profiles in (guix
              ;; profiles) tries to read from this file. Because the environment
              ;; is cleaned in build-self.scm, xdg-directory in (guix utils)
              ;; falls back to accessing /etc/passwd.
              (mkdir "/etc")
              (call-with-output-file "/etc/passwd"
                (lambda (port)
                  (display "root:x:0:0::/root:/bin/bash" port))))
           inferior))

        (let ((channel-instance
               ;; Obtain a session level lock here, to avoid conflicts with
               ;; other jobs over the Git repository.
               (with-advisory-session-lock/log-time
                conn
                'latest-channel-instances
                (lambda ()
                  (first
                   (latest-channel-instances store
                                             (list channel)
                                             #:authenticate?
                                             fetch-with-authentication?))))))
          (inferior-eval '(use-modules (srfi srfi-1)
                                       (ice-9 history)
                                       (guix channels)
                                       (guix grafts)
                                       (guix profiles))
                         inferior)
          (inferior-eval '(%graft? #f)
                         inferior)
          (inferior-eval '(disable-value-history!)
                         inferior)
          (inferior-eval '(define channel-instance
                            (@@ (guix channels) channel-instance))
                         inferior)

          (let* ((systems
                  (inferior-eval '(@ (guix packages) %supported-systems)
                                 inferior))
                 (result
                  (inferior-eval-with-store
                   inferior
                   store
                   (inferior-code channel-instance systems))))

            (close-inferior inferior)

            (cons
             (channel-instance-checkout channel-instance)
             result))))

      (catch
        #t
        (lambda ()
          (with-throw-handler #t
            start-inferior-and-return-derivation-file-names
            (lambda (key . parameters)
              (display (backtrace) (current-error-port))
              (display "\n" (current-error-port))
              (simple-format (current-error-port)
                             "error: channel->derivation-file-names-by-system: ~A: ~A\n"
                             key parameters))))
        (lambda args
          (close-inferior inferior)
          #f))))

(define (channel->source-and-derivations-by-system conn store channel
                                                   fetch-with-authentication?)
  (match (with-time-logging "computing the channel derivation"
           (channel->source-and-derivation-file-names-by-system
            conn
            store
            channel
            fetch-with-authentication?))
    ((source . derivation-file-names-by-system)
     (for-each
      (match-lambda
        ((system . derivation-file-name)
         (simple-format (current-error-port)
                        "debug: ~A: channel dervation: ~A\n"
                        system
                        derivation-file-name)))
      derivation-file-names-by-system)

     (cons source derivation-file-names-by-system))))

(prevent-inlining-for-tests channel->source-and-derivations-by-system)

(define (channel-derivations-by-system->guix-store-item
         store
         channel-derivations-by-system)

  (define (store-item->guix-store-item filename)
    (dirname
     (readlink
      (string-append filename "/bin"))))

  (let ((derivation-file-name-for-current-system
         (assoc-ref
          (assoc-ref channel-derivations-by-system
                     (%current-system))
          'profile)))
    (if derivation-file-name-for-current-system
        (let ((derivation-for-current-system
               (read-derivation-from-file derivation-file-name-for-current-system)))
          (with-time-logging "building the channel derivation"
            (build-derivations store (list derivation-for-current-system)))

          (store-item->guix-store-item
           (derivation->output-path derivation-for-current-system)))
        #f)))

(prevent-inlining-for-tests channel-derivations-by-system->guix-store-item)

(define (glibc-locales-for-guix-store-path store store-path)
  (let ((inf (if (defined?
                   'open-inferior/container
                   (resolve-module '(guix inferior)))
                 (open-inferior/container store store-path
                                          #:extra-shared-directories
                                          '("/gnu/store"))
                 (begin
                   (simple-format #t "debug: using open-inferior\n")
                   (open-inferior store-path
                                  #:error-port (inferior-error-port))))))
    (inferior-eval '(use-modules (srfi srfi-1)
                                 (srfi srfi-34)
                                 (guix grafts)
                                 (guix derivations))
                   inf)
    (inferior-eval '(when (defined? '%graft?) (%graft? #f)) inf)

    (let* ((inferior-glibc-locales
            (first
             (lookup-inferior-packages inf "glibc-locales")))
           (derivation (inferior-package-derivation store
                                                    inferior-glibc-locales))
           (output (derivation->output-path derivation)))
      (close-inferior inf)
      (with-time-logging "building the glibc-locales derivation"
        (build-derivations store (list derivation)))

      output)))

(define (start-inferior-for-data-extration store store-path)
  (let* ((guix-locpath (getenv "GUIX_LOCPATH"))
         (inf (let ((guix-locpath
                     ;; Augment the GUIX_LOCPATH to include glibc-locales from
                     ;; the Guix at store-path, this should mean that the
                     ;; inferior Guix works, even if it's build using a different
                     ;; glibc version
                     (string-append
                      (glibc-locales-for-guix-store-path store store-path)
                      "/lib/locale"
                      ":" guix-locpath)))
                ;; Unset the GUILE_LOAD_PATH and GUILE_LOAD_COMPILED_PATH to
                ;; avoid the values for these being used in the
                ;; inferior. Even though the inferior %load-path and
                ;; %load-compiled-path has the inferior modules first, this
                ;; can cause issues when there are modules present outside
                ;; of the inferior Guix which aren't present in the inferior
                ;; Guix (like the new (guix lint) module
                (unsetenv "GUILE_LOAD_PATH")
                (unsetenv "GUILE_LOAD_COMPILED_PATH")
                (simple-format (current-error-port) "debug: set GUIX_LOCPATH to ~A\n"
                               guix-locpath)
                (if (defined?
                      'open-inferior/container
                      (resolve-module '(guix inferior)))
                    (open-inferior/container store store-path
                                             #:extra-shared-directories
                                             '("/gnu/store")
                                             #:extra-environment-variables
                                             (list (string-append
                                                    "GUIX_LOCPATH="
                                                    guix-locpath)))
                    (begin
                      (setenv "GUIX_LOCPATH" guix-locpath)
                      (simple-format #t "debug: using open-inferior\n")
                      (open-inferior store-path
                                     #:error-port (inferior-error-port)))))))
    (setenv "GUIX_LOCPATH" guix-locpath) ; restore GUIX_LOCPATH

    (when (eq? inf #f)
      (error "error: inferior is #f"))

    ;; Normalise the locale for the inferior process
    (with-exception-handler
        (lambda (key . args)
          (simple-format
           (current-error-port)
           "warning: failed to set locale to en_US.UTF-8: ~A ~A\n"
           key args))
      (lambda ()
        (inferior-eval '(setlocale LC_ALL "en_US.UTF-8") inf)))

    (inferior-eval '(use-modules (srfi srfi-1)
                                 (srfi srfi-34)
                                 (ice-9 history)
                                 (guix grafts)
                                 (guix derivations)
                                 (gnu tests))
                   inf)

    (inferior-eval '(disable-value-history!)
                   inf)

    ;; For G_ and P_
    (or (inferior-eval '(and (resolve-module '(guix i18n) #:ensure #f)
                             (use-modules (guix i18n))
                             #t)
                       inf)
        (inferior-eval '(use-modules (guix ui))
                       inf))

    (inferior-eval '(when (defined? '%graft?) (%graft? #f)) inf)

    inf))

(define* (extract-information-from conn store guix-revision-id commit
                                   guix-source store-path
                                   #:key skip-system-tests?)
  (simple-format #t "debug: extract-information-from: ~A\n" store-path)

  (let ((inf (start-inferior-for-data-extration store store-path)))
    (catch
      #t
      (lambda ()
        (let* ((packages
                (with-time-logging "fetching inferior packages"
                  (inferior-packages-plus-replacements inf)))
               (inferior-lint-warnings
                (with-time-logging "fetching inferior lint warnings"
                  (all-inferior-lint-warnings inf store packages)))
               (inferior-data-4-tuples
                (with-time-logging "getting inferior derivations"
                  (all-inferior-package-derivations store inf packages)))
               (inferior-system-tests
                (if skip-system-tests?
                    (begin
                      (simple-format #t "debug: skipping system tests\n")
                      '())
                    (with-time-logging "getting inferior system tests"
                      (all-inferior-system-tests inf store
                                                 guix-source commit))))
               (packages-data
                (with-time-logging "getting all inferior package data"
                  (all-inferior-packages-data inf packages))))

          (simple-format
           #t "debug: finished loading information from inferior\n")
          (close-inferior inf)

          (with-time-logging
              "acquiring advisory transaction lock: load-new-guix-revision-inserts"
            ;; Wait until this is the only transaction inserting data, to
            ;; avoid any concurrency issues
            (obtain-advisory-transaction-lock conn
                                              'load-new-guix-revision-inserts))
          (let* ((package-ids
                  (insert-packages conn packages-data))
                 (inferior-package-id->package-database-id
                  (let ((lookup-table
                         (alist->hashq-table
                          (map (lambda (package package-id)
                                 (cons (inferior-package-id package)
                                       package-id))
                               packages
                               package-ids))))
                    (lambda (inferior-id)
                      (or
                       (hashq-ref lookup-table inferior-id)
                       (error
                        (simple-format
                         #f
                         "error: inferior-package-id->package-database-id: ~A missing\n"
                         inferior-id)))))))


            (when inferior-lint-warnings
              (let* ((lint-checker-ids
                      (lint-checkers->lint-checker-ids
                       conn
                       (map (match-lambda
                              ((name descriptions-by-locale network-dependent)
                               (list
                                name
                                network-dependent
                                (lint-checker-description-data->lint-checker-description-set-id
                                 conn descriptions-by-locale))))
                            (map car inferior-lint-warnings))))
                     (lint-warning-ids
                      (insert-lint-warnings
                       conn
                       inferior-package-id->package-database-id
                       lint-checker-ids
                       inferior-lint-warnings)))
                (insert-guix-revision-lint-checkers conn
                                                    guix-revision-id
                                                    lint-checker-ids)

                (chunk-for-each!
                 (lambda (lint-warning-ids-chunk)
                   (insert-guix-revision-lint-warnings conn
                                                       guix-revision-id
                                                       lint-warning-ids-chunk))
                 5000
                 lint-warning-ids)))

            (when inferior-system-tests
              (insert-system-tests-for-guix-revision conn
                                                     guix-revision-id
                                                     inferior-system-tests))

            (let* ((package-derivation-ids
                    (with-time-logging "inferior-data->package-derivation-ids"
                      (inferior-data->package-derivation-ids
                       conn inf inferior-package-id->package-database-id
                       inferior-data-4-tuples)))
                   (ids-count
                    (length package-derivation-ids)))
              (chunk-for-each! (lambda (package-derivation-ids-chunk)
                                 (insert-guix-revision-package-derivations
                                  conn
                                  guix-revision-id
                                  package-derivation-ids-chunk))
                               2000
                               package-derivation-ids)
              (simple-format
               #t "Successfully loaded ~A package/derivation pairs\n"
               ids-count))

            (with-time-logging
                "insert-guix-revision-package-derivation-distribution-counts"
              (insert-guix-revision-package-derivation-distribution-counts
               conn
               guix-revision-id))))
        #t)
      (lambda (key . args)
        (simple-format (current-error-port)
                       "Failed extracting information from commit: ~A\n\n" commit)
        (simple-format (current-error-port)
                       "  ~A ~A\n\n" key args)
        #f)
      (lambda (key . args)
        (display-backtrace (make-stack #t) (current-error-port))))))

(prevent-inlining-for-tests extract-information-from)

(define (load-channel-instances git-repository-id commit
                                channel-derivations-by-system)
  ;; Load the channel instances in a different transaction, so that this can
  ;; commit prior to the outer transaction
  (with-postgresql-connection
   "load-new-guix-revision insert channel instances"
   (lambda (channel-instances-conn)
     (with-postgresql-transaction
      channel-instances-conn
      (lambda (channel-instances-conn)

        (with-time-logging
            "acquiring advisory transaction lock: load-new-guix-revision-inserts"
          ;; Wait until this is the only transaction inserting data, to avoid
          ;; any concurrency issues
          (obtain-advisory-transaction-lock channel-instances-conn
                                            'load-new-guix-revision-inserts))

        (let* ((existing-guix-revision-id
                (git-repository-id-and-commit->revision-id channel-instances-conn
                                                           git-repository-id
                                                           commit))
               (guix-revision-id
                (or existing-guix-revision-id
                    (insert-guix-revision channel-instances-conn
                                          git-repository-id commit))))
          (unless existing-guix-revision-id
            (insert-channel-instances channel-instances-conn
                                      guix-revision-id
                                      (filter-map
                                       (match-lambda
                                         ((system . derivations)
                                          (and=>
                                           (assoc-ref derivations
                                                      'manifest-entry-item)
                                           (lambda (drv)
                                             (cons system drv)))))
                                       channel-derivations-by-system))
            (simple-format
             (current-error-port)
             "guix-data-service: saved the channel instance derivations to the database\n"))

          guix-revision-id))))))

(prevent-inlining-for-tests load-channel-instances)

(define* (load-new-guix-revision conn store git-repository-id commit
                                 #:key skip-system-tests?)
  (let* ((git-repository-fields
          (select-git-repository conn git-repository-id))
         (git-repository-url
          (second git-repository-fields))
         (fetch-with-authentication?
          (fourth git-repository-fields))
         (channel-for-commit
          (channel (name 'guix)
                   (url git-repository-url)
                   (commit commit)))
         (source-and-channel-derivations-by-system
          (channel->source-and-derivations-by-system conn
                                                     store
                                                     channel-for-commit
                                                     fetch-with-authentication?))
         (guix-source
          (car source-and-channel-derivations-by-system))
         (channel-derivations-by-system
          (cdr source-and-channel-derivations-by-system))
         (guix-revision-id
          (load-channel-instances git-repository-id commit
                                  channel-derivations-by-system)))
    (let ((store-item
           (channel-derivations-by-system->guix-store-item
            store
            channel-derivations-by-system)))
      (if store-item
          (and
           (extract-information-from conn store
                                     guix-revision-id
                                     commit guix-source store-item
                                     #:skip-system-tests?
                                     skip-system-tests?)

           (if (defined? 'channel-news-for-commit
                 (resolve-module '(guix channels)))
               (with-time-logging "inserting channel news entries"
                 (insert-channel-news-entries-for-guix-revision
                  conn
                  guix-revision-id
                  (channel-news-for-commit channel-for-commit commit)))
               (begin
                 (simple-format
                  #t "debug: importing channel news not supported\n")
                 #t))

           (update-package-derivations-table conn
                                             git-repository-id
                                             guix-revision-id
                                             commit)
           (with-time-logging "updating builds.derivation_output_details_set_id"
             (update-builds-derivation-output-details-set-id
              conn
              (string->number guix-revision-id))))
          (begin
            (simple-format #t "Failed to generate store item for ~A\n"
                           commit)
            #f)))))

(define (enqueue-load-new-guix-revision-job conn git-repository-id commit source)
  (define query
    "
INSERT INTO load_new_guix_revision_jobs (git_repository_id, commit, source)
VALUES ($1, $2, $3)
ON CONFLICT DO NOTHING
RETURNING id;")

  (match (exec-query conn
                     query
                     (list (number->string git-repository-id)
                           commit
                           source))
    ((result)
     result)
    (() #f)))

(define (select-load-new-guix-revision-job-metrics conn)
  (define query
    "
SELECT COALESCE(git_repositories.label, git_repositories.url) AS repository_label,
       CASE WHEN succeeded_at IS NOT NULL
            THEN 'succeeded'
            WHEN (
                   SELECT COUNT(*)
                   FROM load_new_guix_revision_job_events
                   WHERE job_id = load_new_guix_revision_jobs.id
                     AND event = 'retry'
                 ) >= (
                   SELECT COUNT(*)
                   FROM load_new_guix_revision_job_events
                   WHERE job_id = load_new_guix_revision_jobs.id
                     AND event = 'failure'
                 )
            THEN 'queued'
            ELSE 'failed'
       END AS state,
       COUNT(*)
FROM load_new_guix_revision_jobs
INNER JOIN git_repositories
  ON load_new_guix_revision_jobs.git_repository_id =
      git_repositories.id
GROUP BY 1, 2")

  (map (match-lambda
         ((label state count)
          (list label
                state
                (string->number count))))
       (exec-query conn query)))

(define (select-job-for-commit conn commit)
  (let ((result
         (exec-query
          conn
          "
SELECT id,
       commit,
       source,
       git_repository_id,
       CASE WHEN succeeded_at IS NOT NULL
            THEN 'succeeded'
            WHEN (
                   SELECT COUNT(*)
                   FROM load_new_guix_revision_job_events
                   WHERE job_id = load_new_guix_revision_jobs.id
                     AND event = 'retry'
                 ) >= (
                   SELECT COUNT(*)
                   FROM load_new_guix_revision_job_events
                   WHERE job_id = load_new_guix_revision_jobs.id
                     AND event = 'failure'
                 )
            THEN 'queued'
            ELSE 'failed'
       END AS state
FROM load_new_guix_revision_jobs WHERE commit = $1"
          (list commit))))
    (match result
      (() #f)
      (((id commit source git_repository_id state))
       `((id                . ,(string->number id))
         (commit            . ,commit)
         (source            . ,source)
         (git_repository_id . ,(string->number git_repository_id))
         (state             . ,state))))))

(define* (select-recent-job-events conn
                                   #:key (limit 8))
  (define query
    (string-append
     "
SELECT
  load_new_guix_revision_jobs.id,
  load_new_guix_revision_jobs.commit,
  load_new_guix_revision_jobs.source,
  load_new_guix_revision_jobs.git_repository_id,
  load_new_guix_revision_job_events.event,
  load_new_guix_revision_job_events.occurred_at
FROM load_new_guix_revision_jobs
INNER JOIN load_new_guix_revision_job_events
  ON load_new_guix_revision_job_events.job_id = load_new_guix_revision_jobs.id
ORDER BY load_new_guix_revision_job_events.occurred_at DESC
LIMIT " (number->string limit)))

  (exec-query conn query))

(define (select-jobs-and-events conn before-id limit)
  (define query
    (string-append
     "
SELECT
  load_new_guix_revision_jobs.id,
  load_new_guix_revision_jobs.commit,
  load_new_guix_revision_jobs.source,
  load_new_guix_revision_jobs.git_repository_id,
  load_new_guix_revision_jobs.created_at,
  load_new_guix_revision_jobs.succeeded_at,
  (
    SELECT JSON_AGG(
      json_build_object('event', event, 'occurred_at', occurred_at) ORDER BY occurred_at ASC
    )
    FROM load_new_guix_revision_job_events
    WHERE job_id = load_new_guix_revision_jobs.id
  ),
  EXISTS (
    SELECT 1 FROM load_new_guix_revision_job_logs WHERE job_id = load_new_guix_revision_jobs.id
  ) AS log_exists
FROM load_new_guix_revision_jobs
"
     (if before-id
         (string-append
          "WHERE load_new_guix_revision_jobs.id < "
          (number->string before-id))
         "")
     "
ORDER BY load_new_guix_revision_jobs.id DESC
"
     (if limit
         (string-append
          "LIMIT " (number->string limit))
         "")))

  (map
   (match-lambda
     ((id commit source git-repository-id created-at succeeded-at
          events-json log-exists?)
      (list id commit source git-repository-id created-at succeeded-at
            (if (or (eq? #f events-json)
                    (string-null? events-json))
                #()
                (json-string->scm events-json))
            (string=? log-exists? "t"))))
   (exec-query conn query)))

(define (select-unprocessed-jobs-and-events conn)
  (define query
    "
SELECT
  load_new_guix_revision_jobs.id,
  load_new_guix_revision_jobs.commit,
  load_new_guix_revision_jobs.source,
  load_new_guix_revision_jobs.git_repository_id,
  load_new_guix_revision_jobs.created_at,
  (
    SELECT JSON_AGG(
      json_build_object('event', event, 'occurred_at', occurred_at) ORDER BY occurred_at ASC
    )
    FROM load_new_guix_revision_job_events
    WHERE job_id = load_new_guix_revision_jobs.id
  ),
  EXISTS (
    SELECT 1 FROM load_new_guix_revision_job_logs WHERE job_id = load_new_guix_revision_jobs.id
  ) AS log_exists,
  commit IN (
    SELECT commit FROM (
      SELECT DISTINCT ON (name)
        name, git_commits.commit
      FROM git_branches
      INNER JOIN git_commits
        ON git_commits.git_branch_id = git_branches.id
      WHERE
        git_branches.git_repository_id = load_new_guix_revision_jobs.git_repository_id
      ORDER BY name, datetime DESC
    ) branches_and_latest_commits
  ) AS latest_branch_commit
FROM load_new_guix_revision_jobs
WHERE
  succeeded_at IS NULL AND
  (
    SELECT COUNT(*)
    FROM load_new_guix_revision_job_events
    WHERE job_id = load_new_guix_revision_jobs.id AND event = 'retry'
  ) >= (
    SELECT COUNT(*)
    FROM load_new_guix_revision_job_events
    WHERE job_id = load_new_guix_revision_jobs.id AND event = 'failure'
  )
ORDER BY latest_branch_commit DESC, id DESC")

  (map
   (match-lambda
     ((id commit source git-repository-id created-at
          events-json log-exists? latest-branch-commit)
      (list id commit source git-repository-id created-at
            (if (or (eq? #f events-json)
                    (string-null? events-json))
                #()
                (json-string->scm events-json))
            (string=? log-exists? "t")
            (string=? latest-branch-commit "t"))))
   (exec-query conn query)))

(define (select-jobs-and-events-for-commit conn commit)
  (define query
    "
SELECT
  load_new_guix_revision_jobs.id,
  load_new_guix_revision_jobs.source,
  load_new_guix_revision_jobs.git_repository_id,
  load_new_guix_revision_jobs.created_at,
  load_new_guix_revision_jobs.succeeded_at,
  (
    SELECT JSON_AGG(
      json_build_object('event', event, 'occurred_at', occurred_at) ORDER BY occurred_at ASC
    )
    FROM load_new_guix_revision_job_events
    WHERE job_id = load_new_guix_revision_jobs.id
  ),
  EXISTS (
    SELECT 1 FROM load_new_guix_revision_job_logs WHERE job_id = load_new_guix_revision_jobs.id
  ) AS log_exists
FROM load_new_guix_revision_jobs
WHERE commit = $1
ORDER BY load_new_guix_revision_jobs.id DESC")

  (map
   (match-lambda
     ((id source git-repository-id created-at succeeded-at
          events-json log-exists?)
      (list id commit source git-repository-id created-at succeeded-at
            (if (or (eq? #f events-json)
                    (string-null? events-json))
                #()
                (json-string->scm events-json))
            (string=? log-exists? "t"))))
   (exec-query conn query (list commit))))

(define (guix-revision-loaded-successfully? conn commit)
  (define query
    "
SELECT EXISTS(
  SELECT 1
  FROM load_new_guix_revision_jobs
  INNER JOIN load_new_guix_revision_job_events
    ON job_id = load_new_guix_revision_jobs.id
  WHERE commit = $1
    AND event = 'success'
)")

  (let ((result (caar
                 (exec-query conn query (list commit)))))
    (string=? result "t")))


(define (most-recent-n-load-new-guix-revision-jobs conn n)
  (let ((result
         (exec-query
          conn
          "
SELECT id, commit, source, git_repository_id
FROM load_new_guix_revision_jobs
ORDER BY id ASC
LIMIT $1"
          (list (number->string n)))))
    result))

(define (select-job-for-update conn id)
  (exec-query
   conn
   "
SELECT id, commit, source, git_repository_id
FROM load_new_guix_revision_jobs
WHERE id = $1
  AND succeeded_at IS NULL
FOR NO KEY UPDATE SKIP LOCKED"
   (list id)))

(define (record-job-event conn job-id event)
  (exec-query
   conn
   (string-append
    "
INSERT INTO load_new_guix_revision_job_events (job_id, event)
VALUES ($1, $2)")
   (list job-id event)))

(define (record-job-succeeded conn id)
  (exec-query
   conn
   (string-append
    "
UPDATE load_new_guix_revision_jobs
SET succeeded_at = clock_timestamp()
WHERE id = $1 ")
   (list id)))

(define (fetch-unlocked-jobs conn)
  (define query "
SELECT
  id,
  commit IN (
    SELECT commit FROM (
      SELECT DISTINCT ON (name)
        name, git_commits.commit
      FROM git_branches
      INNER JOIN git_commits
        ON git_commits.git_branch_id = git_branches.id
      WHERE
        git_branches.git_repository_id = load_new_guix_revision_jobs.git_repository_id
      ORDER BY name, datetime DESC
    ) branches_and_latest_commits
  ) AS latest_branch_commit
FROM load_new_guix_revision_jobs
WHERE
  succeeded_at IS NULL AND
  (
    SELECT COUNT(*)
    FROM load_new_guix_revision_job_events
    WHERE job_id = load_new_guix_revision_jobs.id AND event = 'retry'
  ) >= (
    SELECT COUNT(*)
    FROM load_new_guix_revision_job_events
    WHERE job_id = load_new_guix_revision_jobs.id AND event = 'failure'
  )
ORDER BY latest_branch_commit DESC, id DESC
FOR NO KEY UPDATE OF load_new_guix_revision_jobs
SKIP LOCKED")

  (map
   (match-lambda
     ((id priority)
      (list id
            (string=? priority "t"))))
   (exec-query conn query)))

(define (with-store-connection f)
  (with-store store
    (set-build-options store #:fallback? #t)

    (f store)))

(prevent-inlining-for-tests with-store-connection)

(define (setup-logging id thunk)
  (let* ((previous-output-port (current-output-port))
         (previous-error-port (current-error-port))
         (result
          (with-postgresql-connection
           (simple-format #f "load-new-guix-revision ~A logging" id)
           (lambda (logging-conn)
             (insert-empty-log-entry logging-conn id)
             (let ((logging-port
                    (log-port id logging-conn
                              #:delete-existing-log-parts? #t)))
               (set-current-output-port logging-port)
               (set-current-error-port logging-port)
               (let ((result
                      (parameterize ((current-build-output-port logging-port)
                                     (real-error-port previous-error-port)
                                     (inferior-error-port
                                      (setup-port-for-inferior-error-output
                                       id previous-error-port)))
                        (thunk))))
                 (set-current-output-port previous-output-port)
                 (set-current-error-port previous-error-port)

                 ;; This can happen with GC, so do it explicitly
                 (close-port logging-port)

                 (combine-log-parts! logging-conn id)

                 result))))))
    result))

(define (cleanup-logging id conn)
  (drop-log-parts-sequence conn id)
  (with-time-logging "vacuuming log parts"
    (vacuum-log-parts-table conn)))

(prevent-inlining-for-tests setup-logging)

(define* (process-load-new-guix-revision-job id #:key skip-system-tests?)
  (with-postgresql-connection
   (simple-format #f "load-new-guix-revision ~A" id)
   (lambda (conn)
     ;; Fix the hash encoding of derivation_output_details. This'll only run
     ;; once on any given database, but is kept here just to make sure any
     ;; instances have the data updated.
     (fix-derivation-output-details-hash-encoding conn)

     (exec-query conn "BEGIN")

     (match (select-job-for-update conn id)
       (((id commit source git-repository-id))

        ;; With a separate connection, outside of the transaction so the event
        ;; gets persisted regardless.
        (with-postgresql-connection
         (simple-format #f "load-new-guix-revision ~A start-event" id)
         (lambda (start-event-conn)
           (record-job-event start-event-conn id "start")))

        (simple-format #t "Processing job ~A (commit: ~A, source: ~A)\n\n"
                       id commit source)

        (if (eq?
             (with-time-logging (string-append "processing revision " commit)
               (setup-logging
                id
                (lambda ()
                  (with-exception-handler
                      (const #f)
                    (lambda ()
                      (with-throw-handler #t
                        (lambda ()
                          (with-store-connection
                           (lambda (store)
                             (load-new-guix-revision conn
                                                     store
                                                     git-repository-id
                                                     commit
                                                     #:skip-system-tests?
                                                     skip-system-tests?))))
                        (lambda (key . args)
                          (simple-format (current-error-port)
                                         "error: load-new-guix-revision: ~A ~A\n"
                                         key args)
                          (backtrace))))
                    #:unwind? #t))))
             #t)
            (begin
              (record-job-succeeded conn id)
              (record-job-event conn id "success")
              (exec-query conn "COMMIT")

              (with-time-logging
                  "cleanup logging"
                (cleanup-logging id conn))

              (with-time-logging
                  "vacuuming package derivations by guix revision range table"
                (vacuum-package-derivations-table conn))

              (with-time-logging
                  "vacuum-derivation-inputs-table"
                (vacuum-derivation-inputs-table conn))

              (match (exec-query
                      conn
                      "SELECT reltuples::bigint FROM pg_class WHERE relname = 'derivation_inputs'")
                (((rows))
                 ;; Don't attempt counting distinct values if there are too
                 ;; many rows, as that is far to slow and could use up all the
                 ;; disk space.
                 (when (< (string->number rows)
                          1000000000)
                   (with-time-logging
                       "update-derivation-inputs-statistics"
                     (update-derivation-inputs-statistics conn)))))

              (with-time-logging
                  "vacuum-derivation-outputs-table"
                (vacuum-derivation-outputs-table conn))

              (with-time-logging
                  "update-derivation-outputs-statistics"
                (update-derivation-outputs-statistics conn))

              #t)
            (begin
              (exec-query conn "ROLLBACK")
              (record-job-event conn id "failure")

              (with-time-logging
                  "cleanup logging"
                (cleanup-logging id conn))

              #f)))
       (()
        (exec-query conn "ROLLBACK")
        (simple-format #t "job ~A not found to be processed\n"
                       id))))))