From a0263a0eae3940eb83aea78845d4714d84db7426 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 24 Apr 2020 09:00:20 +0100
Subject: [PATCH] Set a statement timeout of 60 seconds for web requests

This will help stop queries running for an unnecessarily long time, longer
than NGinx will wait for example.
---
 guix-data-service/web/controller.scm | 10 ++++++----
 guix-data-service/web/server.scm     | 30 +++++++++++++++-------------
 scripts/guix-data-service.in         | 22 ++++++++++++++------
 3 files changed, 38 insertions(+), 24 deletions(-)

diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 15d1b17..d1cba66 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -185,9 +185,10 @@
 (define %show-error-details
   (make-parameter #f))
 
-(define (controller request method-and-path-components
-                    mime-types body
-                    secret-key-base)
+(define* (controller request method-and-path-components
+                     mime-types body
+                     secret-key-base
+                     #:key postgresql-statement-timeout)
   (define (controller-thunk)
     (match method-and-path-components
       (('GET "assets" rest ...)
@@ -236,7 +237,8 @@
                                                mime-types
                                                body
                                                conn
-                                               secret-key-base))))))
+                                               secret-key-base))
+        #:statement-timeout postgresql-statement-timeout))))
   (call-with-error-handling
    controller-thunk
    #:on-error 'backtrace
diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm
index 452ce6c..8f0ce56 100644
--- a/guix-data-service/web/server.scm
+++ b/guix-data-service/web/server.scm
@@ -29,30 +29,32 @@
   #:use-module (guix-data-service web util)
   #:export (start-guix-data-service-web-server))
 
-(define (run-controller controller request body secret-key-base)
-  (let-values (((request-components mime-types)
-                (request->path-components-and-mime-type request)))
-    (controller request
-                (cons (request-method request)
-                      request-components)
-                mime-types
-                body
-                secret-key-base)))
-
-(define (handler request body controller secret-key-base)
+(define (handler request body controller secret-key-base
+                 postgresql-statement-timeout)
   (display
    (format #f "~a ~a\n"
            (request-method request)
            (uri-path (request-uri request))))
   (apply values
-         (run-controller controller request body secret-key-base)))
+         (let-values (((request-components mime-types)
+                       (request->path-components-and-mime-type request)))
+           (controller request
+                       (cons (request-method request)
+                             request-components)
+                       mime-types
+                       body
+                       secret-key-base
+                       #:postgresql-statement-timeout
+                       postgresql-statement-timeout))))
 
-(define (start-guix-data-service-web-server port host secret-key-base)
+(define* (start-guix-data-service-web-server port host secret-key-base
+                                             #:key postgresql-statement-timeout)
   (call-with-error-handling
    (lambda ()
      (run-server (lambda (request body)
                    (handler request body controller
-                            secret-key-base))
+                            secret-key-base
+                            postgresql-statement-timeout))
                  #:host host
                  #:port port))
    #:on-error 'backtrace
diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in
index a09a204..70274d0 100644
--- a/scripts/guix-data-service.in
+++ b/scripts/guix-data-service.in
@@ -82,8 +82,13 @@
                 (lambda (opt name arg result)
                   (alist-cons 'host
                               arg
-                              (alist-delete 'host result))))))
-
+                              (alist-delete 'host result))))
+        (option '("postgresql-statement-timeout") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'postgresql-statement-timeout
+                              (string->number arg)
+                              (alist-delete 'postgresql-statement-timeout
+                                            result))))))
 
 (define %default-options
   ;; Alist of default option values
@@ -97,7 +102,9 @@
           ("" #f)
           (_ #t)))
     (port                                 . 8765)
-    (host                                 . "0.0.0.0")))
+    (host                                 . "0.0.0.0")
+    (postgresql-statement-timeout         . 60000)))
+
 
 (define (parse-options args)
   (args-fold
@@ -187,6 +194,9 @@
                    (assq-ref opts 'host)
                    (assq-ref opts 'port))
 
-    (start-guix-data-service-web-server (assq-ref opts 'port)
-                                        (assq-ref opts 'host)
-                                        (assq-ref opts 'secret-key-base))))
+    (start-guix-data-service-web-server
+     (assq-ref opts 'port)
+     (assq-ref opts 'host)
+     (assq-ref opts 'secret-key-base)
+     #:postgresql-statement-timeout
+     (assq-ref opts 'postgresql-statement-timeout))))