[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Ludovic Courtès |
|
Date: |
Mon, 22 Jan 2018 17:41:39 -0500 (EST) |
branch: master
commit ee11ba1d93b24753eafcd77eef8543e5cac5ba4c
Author: Ludovic Courtès <address@hidden>
Date: Mon Jan 22 23:07:10 2018 +0100
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'.
---
README | 1 +
bin/cuirass.in | 50 ++++++++++++++++++++-----------
configure.ac | 10 +++----
src/cuirass/base.scm | 78 ++++++++++++++++++++++++++++++++++--------------
src/cuirass/database.scm | 12 ++++----
src/cuirass/http.scm | 5 ++--
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:address@hidden@} --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:address@hidden@} --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 <address@hidden>
-# Copyright © 2017 Ludovic Courtès <address@hidden>
+# Copyright © 2017, 2018 Ludovic Courtès <address@hidden>
# Copyright © 2017 Mathieu Othacehe <address@hidden>
#
# 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)))