Move to using Guile KnotsHEADmaster

4 files changed, 49 insertions, 73 deletions

diff --git a/bffe.scm b/bffe.scm
index beba5c4..0c8f58c 100644
--- a/bffe.scm
+++ b/bffe.scm
@@ -27,8 +27,7 @@
   #:use-module (fibers scheduler)
   #:use-module (fibers channels)
   #:use-module (fibers conditions)
-  #:use-module ((guix-build-coordinator utils fibers)
-                #:select (call-with-sigint))
+  #:use-module (knots)
   #:use-module (bffe server)
   #:use-module (bffe manage-builds)
   #:export (run-bffe-service))
diff --git a/bffe/manage-builds.scm b/bffe/manage-builds.scm
index 46276c2..9a4bd3e 100644
--- a/bffe/manage-builds.scm
+++ b/bffe/manage-builds.scm
@@ -28,6 +28,8 @@
   #:use-module (json)
   #:use-module (fibers)
   #:use-module (fibers channels)
+  #:use-module (knots queue)
+  #:use-module (knots parallelism)
   #:use-module (guix records)
   #:use-module (web uri)
   #:use-module (web response)
@@ -151,7 +153,9 @@
                             500))))))
 
 (define* (fiberize proc #:key (parallelism 1))
-  (let ((channel (make-channel)))
+  (let* ((channel (make-channel))
+         (queue-channel
+          (spawn-queueing-fiber channel)))
     (for-each
      (lambda _
        (spawn-fiber
@@ -180,74 +184,11 @@
 
     (lambda args
       (let ((reply-channel (make-channel)))
-        (put-message channel (cons reply-channel args))
+        (put-message queue-channel (cons reply-channel args))
         (match (get-message reply-channel)
           (('result . vals) (apply values vals))
           (('exception . exn) (raise-exception exn)))))))
 
-(define (fibers-map proc . lists)
-  (let ((channels
-         (apply
-          map
-          (lambda args
-            (let ((channel (make-channel)))
-              (spawn-fiber
-               (lambda ()
-                 (put-message
-                  channel
-                  (with-exception-handler
-                      (lambda (exn)
-                        (cons 'exception exn))
-                    (lambda ()
-                      (with-throw-handler #t
-                        (lambda ()
-                          (call-with-values
-                              (lambda ()
-                                (apply proc args))
-                            (lambda val
-                              (cons 'result val))))
-                        (lambda _
-                          (backtrace))))
-                    #:unwind? #t))))
-              channel))
-          lists)))
-    (map
-     (match-lambda
-       (('result . val) val)
-       (('exception . exn) (raise-exception exn)))
-     (map get-message channels))))
-
-(define (fibers-for-each proc . lists)
-  ;; Like split-at, but don't care about the order of the resulting lists, and
-  ;; don't error if the list is shorter than i elements
-  (define (split-at* lst i)
-    (let lp ((l lst) (n i) (acc '()))
-      (if (or (<= n 0) (null? l))
-          (values (reverse! acc) l)
-          (lp (cdr l) (- n 1) (cons (car l) acc)))))
-
-  ;; As this can be called with lists with tens of thousands of items in them,
-  ;; batch the
-  (define batch-size 20)
-  (define (get-batch lists)
-    (let ((split-lists
-           (map (lambda (lst)
-                  (let ((batch rest (split-at* lst batch-size)))
-                    (cons batch rest)))
-                lists)))
-      (values (map car split-lists)
-              (map cdr split-lists))))
-
-  (let loop ((lists lists))
-    (call-with-values
-        (lambda ()
-          (get-batch lists))
-      (lambda (batch rest)
-        (apply fibers-map proc batch)
-        (unless (null? (car rest))
-          (loop  rest)))))
-  *unspecified*)
-
 (define (all-repository-ids guix-data-service)
   (let ((data (guix-data-service-request guix-data-service
                                          "/repositories.json"
diff --git a/bffe/server.scm b/bffe/server.scm
index eae7291..0c8c5d1 100644
--- a/bffe/server.scm
+++ b/bffe/server.scm
@@ -36,10 +36,11 @@
   #:use-module (system repl error-handling)
   #:use-module (fibers)
   #:use-module (fibers channels)
+  #:use-module (knots web-server)
   #:use-module ((guix store) #:select (%store-prefix))
   #:use-module (guix-data-service web util)
   #:use-module ((guix-build-coordinator utils fibers)
-                #:select (run-server/patched retry-on-error))
+                #:select (retry-on-error))
   #:use-module (bffe config)
   #:use-module (bffe view util)
   #:use-module (bffe view home)
@@ -631,8 +632,10 @@
         (sleep 1))
 
       (simple-format #t "Starting the server\n")
-      (run-server/patched (lambda (request body)
-                            (apply values
-                                   (handler request body controller)))
-                          #:host host
-                          #:port port))))
+      (run-knots-web-server
+       (lambda (request)
+         (let ((body (read-request-body request)))
+           (apply values
+                  (handler request body controller))))
+       #:host host
+       #:port port))))
diff --git a/guix-dev.scm b/guix-dev.scm
index 2fd1981..183c721 100644
--- a/guix-dev.scm
+++ b/guix-dev.scm
@@ -42,6 +42,38 @@
              (gnu packages ruby)
              (srfi srfi-1))
 
+(define guile-knots
+  (let ((commit "e8ab6f23d8611c6ebb308007306a9ec5752cfbf0")
+        (revision "1"))
+    (package
+    (name "guile-knots")
+    (version (git-version "0" revision commit))
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://git.cbaines.net/git/guile/knots")
+                    (commit commit)))
+              (sha256
+               (base32
+                "1gbf6g0irjndvbycr3ygi6sh6y19v0h3h45460xgz46p62jiphsp"))
+              (file-name (string-append name "-" version "-checkout"))))
+    (build-system gnu-build-system)
+    (native-inputs
+     (list pkg-config
+           autoconf
+           automake
+           guile-3.0
+           guile-fibers))
+    (inputs
+     (list guile-3.0))
+    (propagated-inputs
+     (list guile-fibers))
+    (home-page "https://git.cbaines.net/guile/knots")
+    (synopsis "Patterns and functionality to use with Guile Fibers")
+    (description
+     "")
+    (license license:gpl3+))))
+
 (package
   (name "bffe")
   (version "0.0.0")
@@ -52,6 +84,7 @@
          guix-data-service
          guile-json-4
          guile-fibers-1.3
+         guile-knots
          guile-readline
          guile-prometheus
          guix-build-coordinator