mirror of
git://git.savannah.gnu.org/guix/guix-cuirass.git
synced 2023-12-14 06:03:04 +01:00
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'.
This commit is contained in:
parent
f9481e2222
commit
ee11ba1d93
6 changed files with 102 additions and 54 deletions
1
README
1
README
|
@ -12,6 +12,7 @@ Cuirass currently depends on the following packages:
|
||||||
- Guile-JSON
|
- Guile-JSON
|
||||||
- Guile-SQLite3
|
- Guile-SQLite3
|
||||||
- Guile-Git
|
- Guile-Git
|
||||||
|
- Fibers
|
||||||
|
|
||||||
A convenient way to install those dependencies is to install Guix and execute
|
A convenient way to install those dependencies is to install Guix and execute
|
||||||
the following command:
|
the following command:
|
||||||
|
|
|
@ -26,7 +26,9 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
||||||
|
|
||||||
(use-modules (cuirass)
|
(use-modules (cuirass)
|
||||||
(cuirass ui)
|
(cuirass ui)
|
||||||
|
(cuirass logging)
|
||||||
(guix ui)
|
(guix ui)
|
||||||
|
(fibers)
|
||||||
(ice-9 getopt-long))
|
(ice-9 getopt-long))
|
||||||
|
|
||||||
(define (show-help)
|
(define (show-help)
|
||||||
|
@ -90,9 +92,11 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
||||||
(let ((one-shot? (option-ref opts 'one-shot #f))
|
(let ((one-shot? (option-ref opts 'one-shot #f))
|
||||||
(port (string->number (option-ref opts 'port "8080")))
|
(port (string->number (option-ref opts 'port "8080")))
|
||||||
(host (option-ref opts 'listen "localhost"))
|
(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)))
|
(specfile (option-ref opts 'specifications #f)))
|
||||||
(prepare-git)
|
(prepare-git)
|
||||||
|
(run-fibers
|
||||||
|
(lambda ()
|
||||||
(with-database db
|
(with-database db
|
||||||
(and specfile
|
(and specfile
|
||||||
(let ((new-specs (save-module-excursion
|
(let ((new-specs (save-module-excursion
|
||||||
|
@ -104,9 +108,19 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
||||||
(if one-shot?
|
(if one-shot?
|
||||||
(process-specs db (db-get-specifications db))
|
(process-specs db (db-get-specifications db))
|
||||||
(begin
|
(begin
|
||||||
(call-with-new-thread
|
(spawn-fiber
|
||||||
(lambda ()
|
(lambda ()
|
||||||
|
(with-database db
|
||||||
(while #t
|
(while #t
|
||||||
(process-specs db (db-get-specifications db))
|
(process-specs db (db-get-specifications db))
|
||||||
(sleep interval))))
|
(log-message "sleeping for ~a seconds" interval)
|
||||||
(run-cuirass-server db #:host host #:port port))))))))))
|
(sleep interval)))))
|
||||||
|
(spawn-fiber
|
||||||
|
(lambda ()
|
||||||
|
(with-database db
|
||||||
|
(run-cuirass-server db
|
||||||
|
#:host host
|
||||||
|
#:port port))))
|
||||||
|
*unspecified*))))
|
||||||
|
|
||||||
|
#:drain? #t)))))))
|
||||||
|
|
10
configure.ac
10
configure.ac
|
@ -1,7 +1,7 @@
|
||||||
## Process this file with autoconf to produce a configure script.
|
## Process this file with autoconf to produce a configure script.
|
||||||
|
|
||||||
# Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
|
# 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>
|
# Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||||
#
|
#
|
||||||
# This file is part of Cuirass.
|
# This file is part of Cuirass.
|
||||||
|
@ -35,11 +35,8 @@ AC_CANONICAL_HOST
|
||||||
AC_PROG_MKDIR_P
|
AC_PROG_MKDIR_P
|
||||||
AC_PROG_SED
|
AC_PROG_SED
|
||||||
|
|
||||||
GUILE_PKG([2.2 2.0])
|
# We need Fibers, which requires 2.2+.
|
||||||
|
GUILE_PKG([2.2])
|
||||||
if test "x$GUILE_EFFECTIVE_VERSION" = "x2.0"; then
|
|
||||||
PKG_CHECK_MODULES([GUILE], [guile-2.0 >= 2.0.7])
|
|
||||||
fi
|
|
||||||
|
|
||||||
AC_PATH_PROG([GUILE], [guile])
|
AC_PATH_PROG([GUILE], [guile])
|
||||||
AC_PATH_PROG([GUILD], [guild])
|
AC_PATH_PROG([GUILD], [guild])
|
||||||
|
@ -51,6 +48,7 @@ GUILE_MODULE_REQUIRED([guix git])
|
||||||
GUILE_MODULE_REQUIRED([git])
|
GUILE_MODULE_REQUIRED([git])
|
||||||
GUILE_MODULE_REQUIRED([json])
|
GUILE_MODULE_REQUIRED([json])
|
||||||
GUILE_MODULE_REQUIRED([sqlite3])
|
GUILE_MODULE_REQUIRED([sqlite3])
|
||||||
|
GUILE_MODULE_REQUIRED([fibers])
|
||||||
|
|
||||||
# We depend on new Guile-Git errors.
|
# We depend on new Guile-Git errors.
|
||||||
GUILE_MODULE_REQUIRED_EXPORT([(git)], git-error-message)
|
GUILE_MODULE_REQUIRED_EXPORT([(git)], git-error-message)
|
||||||
|
|
|
@ -20,6 +20,7 @@
|
||||||
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
|
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(define-module (cuirass base)
|
(define-module (cuirass base)
|
||||||
|
#:use-module (fibers)
|
||||||
#:use-module (cuirass logging)
|
#:use-module (cuirass logging)
|
||||||
#:use-module (cuirass database)
|
#:use-module (cuirass database)
|
||||||
#:use-module (gnu packages)
|
#:use-module (gnu packages)
|
||||||
|
@ -56,6 +57,17 @@
|
||||||
%use-substitutes?
|
%use-substitutes?
|
||||||
%fallback?))
|
%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
|
(cond-expand
|
||||||
(guile-2.2
|
(guile-2.2
|
||||||
;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
|
;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
|
||||||
|
@ -164,9 +176,16 @@ directory and the sha1 of the top level commit in this directory."
|
||||||
evaluation-error?
|
evaluation-error?
|
||||||
(name evaluation-error-spec-name))
|
(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)
|
(define (evaluate store db spec)
|
||||||
"Evaluate and build package derivations. Return a list of jobs."
|
"Evaluate and build package derivations. Return a list of jobs."
|
||||||
(let* ((port (open-pipe* OPEN_READ
|
(let* ((port (non-blocking-port
|
||||||
|
(open-pipe* OPEN_READ
|
||||||
"evaluate"
|
"evaluate"
|
||||||
(string-append (%package-cachedir) "/"
|
(string-append (%package-cachedir) "/"
|
||||||
(assq-ref spec #:name) "/"
|
(assq-ref spec #:name) "/"
|
||||||
|
@ -174,8 +193,10 @@ directory and the sha1 of the top level commit in this directory."
|
||||||
(%guix-package-path)
|
(%guix-package-path)
|
||||||
(%package-cachedir)
|
(%package-cachedir)
|
||||||
(object->string spec)
|
(object->string spec)
|
||||||
(%package-database)))
|
(%package-database))))
|
||||||
(jobs (match (read port)
|
;; 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,
|
;; If an error occured during evaluation report it,
|
||||||
;; otherwise, suppose that data read from port are
|
;; otherwise, suppose that data read from port are
|
||||||
;; correct and keep things going.
|
;; correct and keep things going.
|
||||||
|
@ -183,9 +204,11 @@ directory and the sha1 of the top level commit in this directory."
|
||||||
(raise (condition
|
(raise (condition
|
||||||
(&evaluation-error
|
(&evaluation-error
|
||||||
(name (assq-ref spec #:name))))))
|
(name (assq-ref spec #:name))))))
|
||||||
(data data))))
|
((? string? data)
|
||||||
|
(call-with-input-string data read)))))
|
||||||
(close-pipe port)
|
(close-pipe port)
|
||||||
jobs))
|
jobs))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Build status.
|
;;; Build status.
|
||||||
|
@ -359,6 +382,10 @@ and so on. "
|
||||||
name commit stamp)
|
name commit stamp)
|
||||||
(when commit
|
(when commit
|
||||||
(unless (string=? commit stamp)
|
(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)
|
(copy-repository-cache checkout spec)
|
||||||
|
|
||||||
(unless (assq-ref spec #:no-compile?)
|
(unless (assq-ref spec #:no-compile?)
|
||||||
|
@ -371,18 +398,23 @@ and so on. "
|
||||||
#:fallback? (%fallback?)
|
#:fallback? (%fallback?)
|
||||||
#:keep-going? #t)
|
#:keep-going? #t)
|
||||||
|
|
||||||
|
(spawn-fiber
|
||||||
|
(lambda ()
|
||||||
(guard (c ((evaluation-error? c)
|
(guard (c ((evaluation-error? c)
|
||||||
(format #t "Failed to evaluate ~s specification.~%"
|
(log-message "failed to evaluate spec '~s'"
|
||||||
(evaluation-error-spec-name c))
|
(evaluation-error-spec-name c))
|
||||||
#f))
|
#f))
|
||||||
(log-message "evaluating '~a' with commit ~s"
|
(log-message "evaluating '~a' with commit ~s"
|
||||||
name commit)
|
name commit)
|
||||||
|
(with-store store
|
||||||
(let* ((spec* (acons #:current-commit commit spec))
|
(let* ((spec* (acons #:current-commit commit spec))
|
||||||
(jobs (evaluate store db spec*)))
|
(jobs (evaluate store db spec*)))
|
||||||
(log-message "building ~a jobs for '~a'"
|
(log-message "building ~a jobs for '~a'"
|
||||||
(length jobs) name)
|
(length jobs) name)
|
||||||
(build-packages store db jobs))))
|
(build-packages store db jobs))))))
|
||||||
(db-add-stamp db spec commit))))))
|
|
||||||
|
;; 'spawn-fiber' returns zero values but we need one.
|
||||||
|
*unspecified*))))))
|
||||||
|
|
||||||
(for-each process jobspecs))
|
(for-each process jobspecs))
|
||||||
|
|
||||||
|
|
|
@ -174,11 +174,13 @@ INSERT INTO Evaluations (specification, revision) VALUES ('~A', '~A');"
|
||||||
|
|
||||||
(define-syntax-rule (with-database db body ...)
|
(define-syntax-rule (with-database db body ...)
|
||||||
"Run BODY with a connection to the database which is bound to DB in BODY."
|
"Run BODY with a connection to the database which is bound to DB in BODY."
|
||||||
(let ((db (db-open)))
|
;; XXX: We don't install an unwind handler to play well with delimited
|
||||||
(dynamic-wind
|
;; continuations and fibers. But as a consequence, we leak DB when BODY
|
||||||
(const #t)
|
;; raises an exception.
|
||||||
(lambda () body ...)
|
(let* ((db (db-open))
|
||||||
(lambda () (db-close db)))))
|
(result (begin body ...)))
|
||||||
|
(db-close db)
|
||||||
|
result))
|
||||||
|
|
||||||
(define* (read-quoted-string #:optional (port (current-input-port)))
|
(define* (read-quoted-string #:optional (port (current-input-port)))
|
||||||
"Read all of the characters out of PORT and return them as a SQL quoted
|
"Read all of the characters out of PORT and return them as a SQL quoted
|
||||||
|
|
|
@ -21,6 +21,7 @@
|
||||||
(define-module (cuirass http)
|
(define-module (cuirass http)
|
||||||
#:use-module (cuirass database)
|
#:use-module (cuirass database)
|
||||||
#:use-module (cuirass utils)
|
#:use-module (cuirass utils)
|
||||||
|
#:use-module (cuirass logging)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (json)
|
#:use-module (json)
|
||||||
#:use-module (web request)
|
#:use-module (web request)
|
||||||
|
@ -160,8 +161,8 @@
|
||||||
(let* ((host-info (gethostbyname host))
|
(let* ((host-info (gethostbyname host))
|
||||||
(address (inet-ntop (hostent:addrtype host-info)
|
(address (inet-ntop (hostent:addrtype host-info)
|
||||||
(car (hostent:addr-list 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
|
(run-server url-handler
|
||||||
'http
|
'fibers ;the fibers web backend
|
||||||
`(#:host ,address #:port ,port)
|
`(#:host ,address #:port ,port)
|
||||||
db)))
|
db)))
|
||||||
|
|
Loading…
Reference in a new issue