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'.

6 files changed, 102 insertions, 54 deletions

diff --git a/README b/README
index 8c86a29..e2540cd 100644
--- a/README
+++ b/README
@@ -12,6 +12,7 @@ Cuirass currently depends on the following packages:
   - Guile-JSON
   - Guile-SQLite3
   - Guile-Git
+  - Fibers
 
 A convenient way to install those dependencies is to install Guix and execute
 the following command:
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)))))))
diff --git a/configure.ac b/configure.ac
index 9c6a597..0de0065 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,7 +1,7 @@
 ## Process this file with autoconf to produce a configure script.
 
 # Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
-# Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 # Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 #
 # This file is part of Cuirass.
@@ -35,11 +35,8 @@ AC_CANONICAL_HOST
 AC_PROG_MKDIR_P
 AC_PROG_SED
 
-GUILE_PKG([2.2 2.0])
-
-if test "x$GUILE_EFFECTIVE_VERSION" = "x2.0"; then
-  PKG_CHECK_MODULES([GUILE], [guile-2.0 >= 2.0.7])
-fi
+# We need Fibers, which requires 2.2+.
+GUILE_PKG([2.2])
 
 AC_PATH_PROG([GUILE], [guile])
 AC_PATH_PROG([GUILD], [guild])
@@ -51,6 +48,7 @@ GUILE_MODULE_REQUIRED([guix git])
 GUILE_MODULE_REQUIRED([git])
 GUILE_MODULE_REQUIRED([json])
 GUILE_MODULE_REQUIRED([sqlite3])
+GUILE_MODULE_REQUIRED([fibers])
 
 # We depend on new Guile-Git errors.
 GUILE_MODULE_REQUIRED_EXPORT([(git)], git-error-message)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 7aeb210..3eb105e 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -20,6 +20,7 @@
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (cuirass base)
+  #:use-module (fibers)
   #:use-module (cuirass logging)
   #:use-module (cuirass database)
   #:use-module (gnu packages)
@@ -56,6 +57,17 @@
             %use-substitutes?
             %fallback?))
 
+(define-syntax-rule (with-store store exp ...)
+  ;; XXX: This is a 'with-store' variant that plays well with delimited
+  ;; continuations and fibers.  The 'with-store' macro in (guix store)
+  ;; currently closes in a 'dynamic-wind' handler, which means it would close
+  ;; the store at each context switch.  Remove this when the real 'with-store'
+  ;; has been fixed.
+  (let* ((store (open-connection))
+         (result (begin exp ...)))
+    (close-connection store)
+    result))
+
 (cond-expand
   (guile-2.2
    ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
@@ -164,18 +176,27 @@ directory and the sha1 of the top level commit in this directory."
   evaluation-error?
   (name evaluation-error-spec-name))
 
+(define (non-blocking-port port)
+  "Make PORT non-blocking and return it."
+  (let ((flags (fcntl port F_GETFL)))
+    (fcntl port F_SETFL (logior O_NONBLOCK flags))
+    port))
+
 (define (evaluate store db spec)
   "Evaluate and build package derivations.  Return a list of jobs."
-  (let* ((port (open-pipe* OPEN_READ
-                           "evaluate"
-                           (string-append (%package-cachedir) "/"
-                                          (assq-ref spec #:name) "/"
-                                          (assq-ref spec #:load-path))
-                           (%guix-package-path)
-                           (%package-cachedir)
-                           (object->string spec)
-                           (%package-database)))
-         (jobs (match (read port)
+  (let* ((port (non-blocking-port
+                (open-pipe* OPEN_READ
+                            "evaluate"
+                            (string-append (%package-cachedir) "/"
+                                           (assq-ref spec #:name) "/"
+                                           (assq-ref spec #:load-path))
+                            (%guix-package-path)
+                            (%package-cachedir)
+                            (object->string spec)
+                            (%package-database))))
+         ;; XXX: Since 'read' is not suspendable as of Guile 2.2.3, we use
+         ;; 'read-string' (which is suspendable) and then 'read'.
+         (jobs (match (read-string port)
                  ;; If an error occured during evaluation report it,
                  ;; otherwise, suppose that data read from port are
                  ;; correct and keep things going.
@@ -183,9 +204,11 @@ directory and the sha1 of the top level commit in this directory."
                   (raise (condition
                           (&evaluation-error
                            (name (assq-ref spec #:name))))))
-                 (data data))))
+                 ((? string? data)
+                  (call-with-input-string data read)))))
     (close-pipe port)
     jobs))
+
 
 ;;;
 ;;; Build status.
@@ -359,6 +382,10 @@ and so on. "
                         name commit stamp)
            (when commit
              (unless (string=? commit stamp)
+               ;; Immediately mark COMMIT as being processed so we don't spawn
+               ;; a concurrent evaluation of that same commit.
+               (db-add-stamp db spec commit)
+
                (copy-repository-cache checkout spec)
 
                (unless (assq-ref spec #:no-compile?)
@@ -371,18 +398,23 @@ and so on. "
                                   #:fallback? (%fallback?)
                                   #:keep-going? #t)
 
-               (guard (c ((evaluation-error? c)
-                          (format #t "Failed to evaluate ~s specification.~%"
-                                  (evaluation-error-spec-name c))
-                          #f))
-                 (log-message "evaluating '~a' with commit ~s"
-                              name commit)
-                 (let* ((spec* (acons #:current-commit commit spec))
-                        (jobs  (evaluate store db spec*)))
-                   (log-message "building ~a jobs for '~a'"
-                                (length jobs) name)
-                   (build-packages store db jobs))))
-             (db-add-stamp db spec commit))))))
+               (spawn-fiber
+                (lambda ()
+                  (guard (c ((evaluation-error? c)
+                             (log-message "failed to evaluate spec '~s'"
+                                          (evaluation-error-spec-name c))
+                             #f))
+                    (log-message "evaluating '~a' with commit ~s"
+                                 name commit)
+                    (with-store store
+                      (let* ((spec* (acons #:current-commit commit spec))
+                             (jobs  (evaluate store db spec*)))
+                        (log-message "building ~a jobs for '~a'"
+                                     (length jobs) name)
+                        (build-packages store db jobs))))))
+
+               ;; 'spawn-fiber' returns zero values but we need one.
+               *unspecified*))))))
 
   (for-each process jobspecs))
 
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 3d7e634..901cdf6 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -174,11 +174,13 @@ INSERT INTO Evaluations (specification, revision) VALUES ('~A', '~A');"
 
 (define-syntax-rule (with-database db body ...)
   "Run BODY with a connection to the database which is bound to DB in BODY."
-  (let ((db (db-open)))
-    (dynamic-wind
-      (const #t)
-      (lambda () body ...)
-      (lambda () (db-close db)))))
+  ;; XXX: We don't install an unwind handler to play well with delimited
+  ;; continuations and fibers.  But as a consequence, we leak DB when BODY
+  ;; raises an exception.
+  (let* ((db (db-open))
+         (result (begin body ...)))
+    (db-close db)
+    result))
 
 (define* (read-quoted-string #:optional (port (current-input-port)))
   "Read all of the characters out of PORT and return them as a SQL quoted
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 83ab294..57326c4 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -21,6 +21,7 @@
 (define-module (cuirass http)
   #:use-module (cuirass database)
   #:use-module (cuirass utils)
+  #:use-module (cuirass logging)
   #:use-module (ice-9 match)
   #:use-module (json)
   #:use-module (web request)
@@ -160,8 +161,8 @@
   (let* ((host-info (gethostbyname host))
          (address (inet-ntop (hostent:addrtype host-info)
                              (car (hostent:addr-list host-info)))))
-    (format (current-error-port) "listening on ~A:~A~%" address port)
+    (log-message "listening on ~A:~A" address port)
     (run-server url-handler
-                'http
+                'fibers                           ;the fibers web backend
                 `(#:host ,address #:port ,port)
                 db)))