[no subject]

[Ludovic Courtès]

branch: main
commit 2c7caf38c1923c8e4237d6a0c9c6cc010a55b870
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri May 24 22:12:03 2024 +0200

    http: Add /build/ID/restart route.
    
    This route restarts short failed builds without further ado and
    redirects to /admin/build/ID/restart in other cases: long builds,
    successful builds, etc.
    
    The goal is to allow users to restart simple failed builds in situations
    where /admin access is restricted to privileged users, for instance via
    an nginx frontend.
    
    * src/cuirass/http.scm (allow-unprivileged-build-restart?): New
    procedure.
    (url-handler): Add handler for GET /build/ID/restart.
    * src/cuirass/templates.scm (build-details): “Restart” button links to
    /build/ID/restart.
    * tests/http.scm ("fill-db"): Add build #3.
    ("/build/1/restart redirects to /admin")
    ("/build/3/restart is unprivileged (failed build)"): New tests.
    ("/api/queue?nr=100"): Adjust accordingly.
---
 src/cuirass/http.scm      | 34 ++++++++++++++++++++++++
 src/cuirass/templates.scm |  3 +--
 tests/http.scm            | 66 +++++++++++++++++++++++++++++++++++++----------
 3 files changed, 88 insertions(+), 15 deletions(-)

diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index a9abb23..15ee10c 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -526,6 +526,13 @@ passed, only display JOBS targeting this SYSTEM."
       (string-append (%static-directory) "/images/" name)
     get-string-all))
 
+(define (allow-unprivileged-build-restart? build)
+  "Return true if BUILD can be restarted even without \"admin
+privileges\"--i.e., without going through a /admin URL."
+  (and (= (build-status failed) (build-current-status build))
+       (< (- (build-completion-time build) (build-start-time build))
+          3600)))
+
 
 ;;;
 ;;; Web server.
@@ -882,6 +889,33 @@ passed, only display JOBS targeting this SYSTEM."
                  . ,(string-append "/build/" (number->string id)
                                    "/details"))))))
            (respond-not-found (uri->string (request-uri request))))))
+    (('GET "build" (= string->number (? integer? id)) "restart")
+     (match (db-get-build id)
+       (#f
+        (respond-not-found (uri->string (request-uri request))))
+       (build
+        ;; Restart BUILD right away if allowed, otherwise redirect to
+        ;; /admin/build/ID/restart.
+        (if (allow-unprivileged-build-restart? build)
+            (begin
+              (db-restart-build! id)
+              (respond
+               (build-response
+                #:code 302
+                #:headers `((location . ,(string->uri-reference
+                                          (string-append "/build/"
+                                                         (number->string id)
+                                                         "/details")))))
+               #:body "Restarting build."))
+            (respond
+             (build-response
+              #:code 302
+              #:headers `((location . ,(string->uri-reference
+                                        (string-append "/admin/build/"
+                                                       (number->string id)
+                                                       "/restart")))))
+             #:body "This operation requires admin rights.")))))
+
     (('GET "output" id)
      (let ((output (db-get-output
                     (string-append (%store-prefix) "/" id))))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 4444a2f..59a1fac 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -771,8 +771,7 @@ the existing SPEC otherwise."
                      (role "menu"))
                   (li (@ (role "menuitem"))
                       (a (@ (class "dropdown-item")
-                            (href "/admin/build/"
-                                  ,(build-id build) "/restart"))
+                            (href "/build/" ,(build-id build) "/restart"))
                          " Restart")))))
     (table
      (@ (class "table table-sm table-hover"))
diff --git a/tests/http.scm b/tests/http.scm
index 6073bae..a124761 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -1,6 +1,6 @@
 ;;; http.scm -- tests for (cuirass http) module
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
-;;; Copyright © 2017, 2018, 2019, 2020, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017-2020, 2023-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;;
@@ -135,6 +135,22 @@
                            (item "/gnu/store/fake-2.0")
                            (derivation derivation))))
                    (creation-time 1501347493)))
+           (build3
+            (build (derivation "/gnu/store/fake3.drv")
+                   (evaluation-id 2)
+                   (specification-name "guix")
+                   (job-name "fake-job")
+                   (system "x86_64-linux")
+                   (nix-name "fake-3.0")
+                   (log "unused so far")
+                   (status (build-status failed)) ;failed!
+                   (outputs
+                    (list (output
+                           (item "/gnu/store/fake-3.0")
+                           (derivation derivation))))
+                   (creation-time 1501347493)
+                   (start-time creation-time)
+                   (completion-time (+ start-time 100))))
            (spec
             (specification
              (name "guix")
@@ -174,7 +190,8 @@
       (db-add-evaluation "guix" checkouts2
                          #:timestamp 1501347493)
       (db-add-build build1)
-      (db-add-build build2)))
+      (db-add-build build2)
+      (db-add-build build3)))
 
   (test-assert "/specifications"
     (match (call-with-input-string
@@ -186,13 +203,33 @@
 
   (test-assert "/build/1"
     (lset= equal?
-     (call-with-input-string
-         (utf8->string
-          (http-get-body (test-cuirass-uri "/build/1")))
-       json->scm)
-     (call-with-input-string
-         (scm->json-string build-query-result)
-       json->scm)))
+           (call-with-input-string
+               (utf8->string
+                (http-get-body (test-cuirass-uri "/build/1")))
+             json->scm)
+           (call-with-input-string
+               (scm->json-string build-query-result)
+             json->scm)))
+
+  (test-equal "/build/1/restart redirects to /admin"
+    (list 302 "/admin/build/1/restart" (build-status succeeded))
+
+    ;; This is a successful build so /build/1/restart redirects to /admin
+    ;; without doing anything.
+    (let ((response (http-get (test-cuirass-uri "/build/1/restart"))))
+      (list (response-code response)
+            (uri-path (response-location response))
+            (build-current-status (db-get-build 1)))))
+
+  (test-equal "/build/3/restart is unprivileged (failed build)"
+    (list 302 "/build/3/details" (build-status scheduled))
+
+    ;; This is a short and failed build so /build/3/restart actually
+    ;; reschedules it.
+    (let ((response (http-get (test-cuirass-uri "/build/3/restart"))))
+      (list (response-code response)
+            (uri-path (response-location response))
+            (build-current-status (db-get-build 3)))))
 
   (test-equal "/build/42"
     404
@@ -249,14 +286,17 @@
        "/api/latestbuilds?nr&jobset=gnu"))))
 
   (test-equal "/api/queue?nr=100"
-    `("fake-2.0" ,(build-status scheduled))
+    `(("fake-2.0" ,(build-status scheduled))
+      ("fake-3.0" ,(build-status scheduled)))
     (match (json-string->scm
             (utf8->string
              (http-get-body
               (test-cuirass-uri "/api/queue?nr=100"))))
-      (#(dictionary)
-       (list (assoc-ref dictionary "nixname")
-             (assoc-ref dictionary "buildstatus")))))
+      (#(first second)
+       (list (list (assoc-ref first "nixname")
+                   (assoc-ref first "buildstatus"))
+             (list (assoc-ref second "nixname")
+                   (assoc-ref second "buildstatus"))))))
 
   (test-equal "/api/evaluations?nr=1"
     (json-string->scm