From ee11ba1d93b24753eafcd77eef8543e5cac5ba4c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 22 Jan 2018 23:07:10 +0100
Subject: Introduce concurrency with Fibers.

* README: Mark Fibers as required.
* configure.ac: Check for Guile 2.2 only.  Check for (fibers).
* bin/cuirass.in (main): Use (fibers).  Run 'process-specs' and web
server in separate fibers.
* src/cuirass/base.scm (with-store): New macro.
(non-blocking-port): New procedure.
(evaluate): Use 'non-blocking-port'.  Use 'read-string' followed by 'read'.
(process-specs): Move 'db-add-stamp' right after 'string=?' comparison.
Run evaluation and subsequent builds in a separate fiber.
* src/cuirass/http.scm (run-cuirass-server): Pass 'fibers as the second
argument to 'run-server'.  Use 'log-message' instead of 'format'.
* src/cuirass/database.scm (with-database): Remove 'dynamic-wind'.
---
 bin/cuirass.in | 50 ++++++++++++++++++++++++++++++++------------------
 1 file changed, 32 insertions(+), 18 deletions(-)

(limited to 'bin')

diff --git a/bin/cuirass.in b/bin/cuirass.in
index f11a6a5..725712d 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -26,7 +26,9 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
 
 (use-modules (cuirass)
              (cuirass ui)
+             (cuirass logging)
              (guix ui)
+             (fibers)
              (ice-9 getopt-long))
 
 (define (show-help)
@@ -90,23 +92,35 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
         (let ((one-shot? (option-ref opts 'one-shot #f))
               (port      (string->number (option-ref opts 'port "8080")))
               (host      (option-ref opts 'listen "localhost"))
-              (interval  (string->number (option-ref opts 'interval "10")))
+              (interval  (string->number (option-ref opts 'interval "300")))
               (specfile  (option-ref opts 'specifications #f)))
           (prepare-git)
-          (with-database db
-            (and specfile
-                 (let ((new-specs (save-module-excursion
-                                   (lambda ()
-                                     (set-current-module (make-user-module '()))
-                                     (primitive-load specfile)))))
-                   (for-each (lambda (spec) (db-add-specification db spec))
-                             new-specs)))
-            (if one-shot?
-                (process-specs db (db-get-specifications db))
-                (begin
-                  (call-with-new-thread
-                   (lambda ()
-                     (while #t
-                       (process-specs db (db-get-specifications db))
-                       (sleep interval))))
-                  (run-cuirass-server db #:host host #:port port))))))))))
+          (run-fibers
+           (lambda ()
+             (with-database db
+               (and specfile
+                    (let ((new-specs (save-module-excursion
+                                      (lambda ()
+                                        (set-current-module (make-user-module '()))
+                                        (primitive-load specfile)))))
+                      (for-each (lambda (spec) (db-add-specification db spec))
+                                new-specs)))
+               (if one-shot?
+                   (process-specs db (db-get-specifications db))
+                   (begin
+                     (spawn-fiber
+                      (lambda ()
+                        (with-database db
+                          (while #t
+                            (process-specs db (db-get-specifications db))
+                            (log-message "sleeping for ~a seconds" interval)
+                            (sleep interval)))))
+                     (spawn-fiber
+                      (lambda ()
+                        (with-database db
+                          (run-cuirass-server db
+                                              #:host host
+                                              #:port port))))
+                     *unspecified*))))
+
+           #:drain? #t)))))))
-- 
cgit v1.2.3