From a171287f27c62b57cdb6dbc3dafa0a082cad8831 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Wed, 1 May 2019 09:24:38 +0100
Subject: [PATCH] Try harder to handle errors when loading new revisions

If the repl enters a bad state, attempt to exit, and catch failures in the
parent process, and rollback the open transaction.
---
 .../jobs/load-new-guix-revision.scm           | 58 +++++++++++++------
 1 file changed, 41 insertions(+), 17 deletions(-)

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index 4218849..95c2554 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -109,12 +109,27 @@
                         supported-systems
                         (list ,@(map car system-target-pairs))))
                       '())))
-              (lambda args
-                (simple-format (current-error-port)
-                               "error: while processing ~A ignoring error: ~A\n"
-                               (package-name package)
-                               args)
-                '()))))
+              (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)
+                      (force-output)
+                      (exit 1))
+                    (begin
+                      (simple-format
+                       (current-error-port)
+                       "error: while processing ~A ignoring error: ~A: ~A\n"
+                       (package-name package)
+                       key
+                       args)
+                      (force-output)
+                      '()))))))
         (list ,@(map inferior-package-id packages)))))
 
   (append-map
@@ -346,20 +361,29 @@
     (inferior-eval '(%graft? #f) inf)
 
     (exec-query conn "BEGIN")
-    (let ((package-derivation-ids
-           (inferior-guix->package-derivation-ids store conn inf))
-          (guix-revision-id
-           (insert-guix-revision conn url commit store-path)))
+    (catch
+      #t
+      (lambda ()
+        (let ((package-derivation-ids
+               (inferior-guix->package-derivation-ids store conn inf))
+              (guix-revision-id
+               (insert-guix-revision conn url commit store-path)))
 
-      (insert-guix-revision-package-derivations conn
-                                                guix-revision-id
-                                                package-derivation-ids)
+          (insert-guix-revision-package-derivations conn
+                                                    guix-revision-id
+                                                    package-derivation-ids)
 
-      (exec-query conn "COMMIT")
+          (exec-query conn "COMMIT")
 
-      (simple-format
-       #t "Successfully loaded ~A package/derivation pairs\n"
-       (length package-derivation-ids)))))
+          (simple-format
+           #t "Successfully loaded ~A package/derivation pairs\n"
+           (length package-derivation-ids))))
+      (lambda (key . args)
+        (simple-format (current-error-port)
+                       "Failed extracting information: ~A ~A\n"
+                       key args)
+        (force-output)
+        (exec-query conn "ROLLBACK")))))
 
 (define (load-new-guix-revision conn url commit)
   (if (guix-revision-exists? conn url commit)