1 files changed, 37 insertions, 19 deletions
diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm
index 8af53da..86747e0 100644
--- a/guix-data-service/database.scm
+++ b/guix-data-service/database.scm
@@ -41,6 +41,8 @@
             with-advisory-session-lock/log-time
             obtain-advisory-transaction-lock
 
+            NULL
+            NULL?
             exec-query-with-null-handling))
 
 ;; TODO This isn't exported for some reason
@@ -170,7 +172,7 @@
           (simple-format #t "running command: ~A\n"
                          (string-join command))
           (let ((pid (spawn (%config 'sqitch) command)))
-            (unless (= 0 (status:exit-val (cdr (waitpid pid))))
+            (unless (= 0 (status:exit-val (cdr (waitpid pid)))) ;; TODO Don't use waitppid
               (simple-format
                (current-error-port)
                "error: sqitch command failed\n")
@@ -178,8 +180,11 @@
 
 (define* (with-postgresql-connection name f #:key (statement-timeout #f))
   (let ((conn (open-postgresql-connection name statement-timeout)))
-    (with-throw-handler
-        #t
+    (with-exception-handler
+        (lambda (exn)
+          (pg-conn-finish conn)
+          (decrement-connection-gauge name)
+          (raise-exception exn))
       (lambda ()
         (call-with-values
             (lambda ()
@@ -189,10 +194,7 @@
 
             (decrement-connection-gauge name)
 
-            (apply values vals))))
-      (lambda (key . args)
-        (pg-conn-finish conn)
-        (decrement-connection-gauge name)))))
+            (apply values vals)))))))
 
 (define %postgresql-connection-parameters
   (make-parameter #f))
@@ -207,15 +209,22 @@
                                       #:key always-rollback?)
   (exec-query conn "BEGIN;")
 
-  (with-throw-handler #t
+  (with-exception-handler
+      (lambda (exn)
+        (with-exception-handler
+            (const #f)
+          (lambda ()
+            (exec-query conn "ROLLBACK;"))
+          #:unwind? #t)
+        ;; TODO Include the stack in the exception via knots
+        (raise-exception exn))
     (lambda ()
       (let ((result (f conn)))
         (exec-query conn (if always-rollback?
                              "ROLLBACK;"
                              "COMMIT;"))
         result))
-    (lambda (key . args)
-      (exec-query conn "ROLLBACK;"))))
+    #:unwind? #t))
 
 (define (check-test-database! conn)
   (match (exec-query conn "SELECT current_database()")
@@ -245,17 +254,22 @@
     (exec-query conn
                 "SELECT pg_advisory_lock($1)"
                 (list lock-number))
-    (with-throw-handler #t
+    (with-exception-handler
+        (lambda (exn)
+          (with-exception-handler
+              (const #f)
+            (lambda ()
+              (exec-query conn
+                          "SELECT pg_advisory_unlock($1)"
+                          (list lock-number)))
+            #:unwind? #t)
+          (raise-exception exn))
       (lambda ()
         (let ((result (f)))
           (exec-query conn
                       "SELECT pg_advisory_unlock($1)"
                       (list lock-number))
-          result))
-      (lambda (key . args)
-        (exec-query conn
-                    "SELECT pg_advisory_unlock($1)"
-                    (list lock-number))))))
+          result)))))
 
 (define (with-advisory-session-lock/log-time conn lock f)
   (simple-format #t "debug: Acquiring advisory session lock: ~A\n" lock)
@@ -279,6 +293,10 @@
                 "SELECT pg_advisory_xact_lock($1)"
                 (list lock-number))))
 
+(define NULL (make-symbol "null"))
+
+(define NULL? (lambda (s) (eq? s NULL)))
+
 (define squee/libpq
   (@@ (squee) libpq))
 
@@ -300,11 +318,11 @@
         (lambda (col-i)
           (let ((val (result-get-value result-ptr row-i col-i)))
             (cond
-             ((eq? #f val) '())
+             ((eq? #f val) NULL)
              ((string-null? val)
-              (if (eq? 1 (%PQgetisnull
+              (if (= 1 (%PQgetisnull
                           (squee/unwrap-result-ptr result-ptr) row-i col-i))
-                  '()
+                  NULL
                   val))
              (else val))))
         cols-range))